Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge 8.7 |
|---|---|
| Timelines: | family | ancestors | descendants | both | tip-567 |
| Files: | files | file ages | folders |
| SHA3-256: |
43e2fb7b6369e201f7ed2976899078fa |
| User & Date: | jan.nijtmans 2021-01-05 09:27:06.844 |
Context
|
2021-01-08
| ||
| 10:48 | Fix memory leak check-in: f4028b1cc3 user: jan.nijtmans tags: tip-567 | |
|
2021-01-05
| ||
| 09:27 | Merge 8.7 check-in: 43e2fb7b63 user: jan.nijtmans tags: tip-567 | |
| 09:19 | Merge 8.6 check-in: 7467a34f63 user: jan.nijtmans tags: core-8-branch | |
|
2020-02-26
| ||
| 08:32 | merge core-8-branch check-in: 7859c7efe0 user: dkf tags: tip-567 | |
Changes
Changes to .fossil-settings/binary-glob.
|
| < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 | *.a *.bmp *.dll *.exe *.gif *.gz *.jpg |
| ︙ | ︙ |
Changes to .fossil-settings/crlf-glob.
1 2 3 4 5 6 7 8 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj | > < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/contrib/vstudio/*/*.sln compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc win/rules-ext.vc win/targets.vc win/tcl.dsp win/tcl.dsw |
Changes to .fossil-settings/encoding-glob.
|
| < < | 1 2 3 4 5 6 7 | tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw |
Changes to .fossil-settings/ignore-glob.
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 | *.a *.dll *.dylib *.exe *.exp *.la *.lib *.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile */config.cache */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf | > > | > > > > > > > > > > | 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 | *.a *.dll *.dylib *.dylib.E *.exe *.exp *.la *.lib *.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile */autom4te.cache */config.cache */config.log */config.status */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/*.bundle unix/dltest/*.dll unix/dltest/*.dylib 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 |
Added .fossil-settings/manifest.
> | 1 | u |
Changes to .gitattributes.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # Declare files that will always have CRLF line endings on checkout. *.bat eol=crlf *.sln eol=crlf *.vc eol=crlf # Denote all files that are truly binary and should not be modified. *.a binary *.dll binary *.exe binary *.gif binary *.gz binary *.jpg binary *.lib binary *.pdf binary | > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | # Declare files that will always have CRLF line endings on checkout. *.bat 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 *.exe binary *.gif binary *.gz binary *.jpg binary *.lib binary *.pdf binary |
| ︙ | ︙ |
Added .github/workflows/linux-build.yml.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
name: Linux
on: [push]
jobs:
gcc:
runs-on: ubuntu-20.04
strategy:
matrix:
cfgopt:
- ""
- "CFLAGS=-DTCL_UTF_MAX=4"
- "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
mkdir "${HOME}/install dir"
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: ${{ matrix.cfgopt }}
- name: Build
run: |
make all
- name: Build Test Harness
run: |
make tcltest
- name: Run Tests
run: |
make test
- name: Test-Drive Installation
run: |
make install
- name: Create Distribution Package
run: |
make dist
- name: Convert Documentation to HTML
run: |
make html-tcl
|
Added .github/workflows/mac-build.yml.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
name: macOS
on: [push]
jobs:
xcode:
runs-on: macos-11.0
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make all
- name: Run Tests
run: make test styles=develop
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
clang:
runs-on: macos-11.0
strategy:
matrix:
cfgopt:
- ""
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "$HOME/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
# Note that macOS is always a 64 bit platform
run: ./configure --enable-64bit --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1)
env:
CFGOPT: ${{ matrix.cfgopt }}
- name: Build
run: |
make all tcltest
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
|
Added .github/workflows/onefiledist.yml.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
name: Build Binaries
on: [push]
jobs:
linux:
name: Linux
runs-on: ubuntu-16.04
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
mkdir 1dist
echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
working-directory: .
- name: Configure
run: ./configure --disable-symbols --disable-shared --enable-zipfs
working-directory: unix
- name: Build
run: |
make tclsh tclzipfile
make shell SCRIPT="$VER_PATH $GITHUB_ENV"
echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
working-directory: unix
- name: Package
run: |
cat ../unix/tclsh $TCL_ZIP > tclsh${TCL_PATCHLEVEL}_unofficial
chmod +x tclsh${TCL_PATCHLEVEL}_unofficial
tar -cf tclsh${TCL_PATCHLEVEL}_unofficial.tar tclsh${TCL_PATCHLEVEL}_unofficial
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Linux single-file build (unofficial)
path: 1dist/*.tar
macos:
name: macOS
runs-on: macos-latest
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Checkout create-dmg
uses: actions/checkout@v2
with:
repository: create-dmg/create-dmg
ref: v1.0.8
path: create-dmg
- name: Prepare
run: |
mkdir 1dist
touch generic/tclStubInit.c generic/tclOOStubInit.c || true
echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV
- name: Configure
run: ./configure --disable-symbols --disable-shared --enable-zipfs
working-directory: unix
- name: Build
run: |
make tclsh tclzipfile
make 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
cat $TCL_BIN $TCL_ZIP > contents/tclsh${TCL_PATCHLEVEL}_unofficial
chmod +x contents/tclsh${TCL_PATCHLEVEL}_unofficial
cat > contents/README.txt <<EOF
This is a single-file executable developer preview of Tcl $TCL_PATCHLEVEL
It is not intended as an official release at all, so it is unsigned and unnotarized.
Use strictly at your own risk.
To run it, you need to copy the executable out and run:
xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_unofficial
to mark the executable as runnable on your machine.
EOF
$CREATE_DMG \
--volname "Tcl $TCL_PATCHLEVEL (unofficial)" \
--window-pos 200 120 \
--window-size 800 400 \
"Tcl-$TCL_PATCHLEVEL-(unofficial).dmg" \
"contents/"
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} macOS single-file build (unofficial)
path: 1dist/*.dmg
win:
name: Windows
runs-on: windows-latest
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Install MSYS2
uses: msys2/setup-msys2@v2
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
mkdir 1dist
working-directory: .
- name: Configure
run: ./configure --disable-symbols --disable-shared --enable-zipfs
working-directory: win
- name: Build
run: |
make binaries libraries tclzipfile
echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
working-directory: win
- name: Package
run: |
cat ../win/tclsh*.exe $TCL_ZIP > combined.exe
working-directory: 1dist
- name: Get Exact Version
run: |
./combined.exe $VER_PATH $GITHUB_ENV
working-directory: 1dist
- name: Set Executable Name
run: |
mv combined.exe tclsh${TCL_PATCHLEVEL}_unofficial.exe
working-directory: 1dist
- name: Upload
uses: actions/upload-artifact@v2
with:
name: Tclsh ${{ env.TCL_PATCHLEVEL }} Windows single-file build (unofficial)
path: '1dist/*_unofficial.exe'
|
Added .github/workflows/win-build.yml.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
name: Windows
on: [push]
jobs:
msvc:
runs-on: windows-latest
defaults:
run:
shell: powershell
working-directory: win
strategy:
matrix:
cfgopt:
- ""
- "OPTS=utfmax"
- "CHECKS=nodep"
- "OPTS=static"
- "OPTS=symbols"
- "OPTS=memdbg"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Init MSVC
uses: ilammy/msvc-dev-cmd@v1
- name: Build ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} all
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Build Test Harness ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} tcltest
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Run Tests ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} test
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
env:
ERROR_ON_FAILURES: 1
CI_BUILD_WITH_MSVC: 1
gcc:
runs-on: windows-latest
defaults:
run:
shell: bash
working-directory: win
strategy:
matrix:
cfgopt:
- ""
- "CFLAGS=-DTCL_UTF_MAX=4"
- "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Install MSYS2 and Make
run: choco install msys2 make
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "${HOME}/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: --enable-64bit ${{ matrix.cfgopt }}
- name: Build
run: make all
- name: Build Test Harness
run: make tcltest
- name: Run Tests
run: make test
env:
ERROR_ON_FAILURES: 1
# 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.
1 2 3 4 5 6 7 8 9 10 11 12 | *.a *.dll *.dylib *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so | > > > | > > > | | | > > > > < > > | 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 | *.a *.bundle *.dll *.dylib *.dylib.E *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so .fslckout Makefile Tcl-Info.plist Tclsh-Info.plist autom4te.cache config.cache config.log config.status config.status.lineno html manifest.uuid _FOSSIL_ */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker 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 |
Changes to .travis.yml.
|
| < | | > > > > > > > > > > > | | | | | | < | | | < < < < < < > > | | | < < | < < | | | | < | | | > > > | | < < < < | | | < | | | > | | > > | > | | > | | | > | > | > > > > | > > > > | | < < < < < < < | < < < < < < < < > | 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 |
language: c
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- binutils-mingw-w64-i686
- binutils-mingw-w64-x86-64
- gcc-mingw-w64
- gcc-mingw-w64-base
- gcc-mingw-w64-i686
- gcc-mingw-w64-x86-64
- gcc-multilib
jobs:
include:
# Testing on Linux GCC
- name: "Linux/GCC/Shared"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- name: "Linux/GCC/Shared: UTF_MAX=4"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=4
- name: "Linux/GCC/Shared: NO_DEPRECATED"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: focal
compiler: gcc
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/GCC/Debug"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/GCC/Mem-Debug"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Newer/Older versions of GCC
- name: "Linux/GCC 10/Shared"
os: linux
dist: focal
compiler: gcc-10
addons:
apt:
packages:
- g++-10
env:
- BUILD_DIR=unix
- name: "Linux/GCC 5/Shared"
os: linux
dist: bionic
compiler: gcc-5
addons:
apt:
packages:
- g++-5
env:
- BUILD_DIR=unix
# Testing on Linux Clang
- name: "Linux/Clang/Shared"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- name: "Linux/Clang/Shared:NO_DEPRECATED"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/Clang/Static"
os: linux
dist: focal
compiler: clang
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/Clang/Debug"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/Clang/Mem-Debug"
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- name: "macOS/Clang/Xcode 12/Shared"
os: osx
osx_image: xcode12.2
env:
- BUILD_DIR=macosx
install: []
script: &mactest
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- name: "macOS/Clang/Xcode 12/Shared/Unix-like"
os: osx
osx_image: xcode12.2
env:
- BUILD_DIR=unix
- CFGOPT="--enable-dtrace"
- name: "macOS/Clang/Xcode 12/Shared/libtommath"
os: osx
osx_image: xcode12.2
env:
- BUILD_DIR=macosx
install: []
script: *mactest
addons:
homebrew:
packages:
- libtommath
# Newer MacOS versions
- name: "macOS/Clang/Xcode 12/Universal Apps/Shared"
os: osx
osx_image: xcode12u
env:
- BUILD_DIR=macosx
install: []
script: *mactest
# Older MacOS versions
- name: "macOS/Clang/Xcode 11/Shared"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 10/Shared"
os: osx
osx_image: xcode10.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 9/Shared"
os: osx
osx_image: xcode9.4
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- name: "macOS/Clang/Xcode 8/Shared"
os: osx
osx_image: xcode8.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
os: linux
dist: focal
compiler: x86_64-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
script: &crosstest
- make all tcltest
# Include a high visibility marker that tests are skipped outright
- >
echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`"
# Test with mingw-w64 (32 bit) cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows-32/GCC/Shared/no test"
os: linux
dist: focal
compiler: i686-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
script: *crosstest
# Test on Windows with MSVC native
- name: "Windows/MSVC/Shared"
os: windows
compiler: cl
env: &vcenv
- BUILD_DIR=win
- VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build"
before_install: &vcpreinst
- touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- PATH="$PATH:$VCDIR"
- cd ${BUILD_DIR}
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test
- name: "Windows/MSVC/Shared: UTF_MAX=4"
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
- name: "Windows/MSVC/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
| | | | | > > > > > > > > > | 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 |
- name: "Windows/MSVC/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static' '-f' makefile.vc test
- name: "Windows/MSVC/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with MSVC native (32-bit)
- name: "Windows/MSVC-x86/Shared"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
- name: "Windows/MSVC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
| | | | | > > > > > > > > > > | 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 |
- name: "Windows/MSVC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with GCC native
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- choco install -y make zip
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=4"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
| > > > > > > > | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols=mem"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 374 375 376 |
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
before_install:
- cd ${BUILD_DIR}
install:
| > > > > > > > > > > > > > > > > > > | | > | 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 |
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC-x86/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols=mem"
before_install: *makepreinst
# "make dist" only
- name: "Linux: make dist"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
script:
- make dist
before_install:
- touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- cd ${BUILD_DIR}
install:
- mkdir "$HOME/install dir"
- ./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
before_script:
- export ERROR_ON_FAILURES=1
script:
- make all tcltest || echo "Something wrong, maybe a hickup, let's try again"
- make test
- make install
|
Changes to ChangeLog.
| ︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | copying an object, make sure that the configuration of the variable resolver is also duplicated. 2012-01-22 Jan Nijtmans <nijtmans@users.sf.net> * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 | copying an object, make sure that the configuration of the variable resolver is also duplicated. 2012-01-22 Jan Nijtmans <nijtmans@users.sf.net> * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be * generic/tclUniData.c: able to handle characters > 0xFFFF. Done in * generic/tclUtf.c: all branches in order to simplify merges for * generic/regc_locale.c: new Unicode versions (such as 6.1) 2012-01-22 Donal K. Fellows <dkf@users.sf.net> * generic/tclDictObj.c (DictExistsCmd): [Bug 3475264]: Ensure that errors only ever happen when insufficient arguments are supplied, and |
| ︙ | ︙ |
Changes to ChangeLog.2000.
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. * tests/*.test: Changed all occurrences of "namespace import ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948]. 2000-04-09 Brent Welch <welch@scriptics.com> * lib/httpd2.1/http.tcl: Worked on the "server closes before reading post data" case, which unfortunately causes different error cases on Solaris, which can read the reply, and Linux and Windows, which cannot |
| ︙ | ︙ |
Changes to ChangeLog.2001.
| ︙ | ︙ | |||
347 348 349 350 351 352 353 | the .exp files and can remove use of #pragma export that never worked well) removed line continuation in #if clause as this breaks the mac resource compiler (note that *.r files include tcl.h) * mac/tclMacFile.c: fixed bug in permission checking code | | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 | the .exp files and can remove use of #pragma export that never worked well) removed line continuation in #if clause as this breaks the mac resource compiler (note that *.r files include tcl.h) * mac/tclMacFile.c: fixed bug in permission checking code * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package names to code fragment names changed to only match on the length of package name, this allows for fragment names with version numbers appended. * mac/tclMacInt.h: * generic/tclInt.h: * mac/tclMacTime.c: |
| ︙ | ︙ | |||
3521 3522 3523 3524 3525 3526 3527 | [Patch 403229] 2001-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to avoid a read off the end of the argument array that could occur when executing something like [unset -nocomplain] was executed. Improved | | | 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 | [Patch 403229] 2001-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to avoid a read off the end of the argument array that could occur when executing something like [unset -nocomplain] was executed. Improved the error message given when not enough arguments are given (-nocomplain should obviously be *before* --, not after it) and also modified the test suite to take account of that and the documentation to use the same improvement. [Bug 405769] 2001-03-02 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tclExecute.c (TclExecuteByteCode): Fixed bug that could pass |
| ︙ | ︙ |
Changes to ChangeLog.2002.
| ︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 | 2002-07-05 Don Porter <dgp@users.sourceforge.net> * changes: added recent changes 2002-07-05 Reinhard Max <max@suse.de> | | | 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 | 2002-07-05 Don Porter <dgp@users.sourceforge.net> * changes: added recent changes 2002-07-05 Reinhard Max <max@suse.de> * generic/tclClock.c (FormatClock): Convert the format string to utf-8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. 2002-07-05 Donal K. Fellows <fellowsd@cs.man.ac.uk> * unix/Makefile.in (ro-test,ddd,GDB,DDD): Created new targets to |
| ︙ | ︙ |
Changes to ChangeLog.2004.
| ︙ | ︙ | |||
2298 2299 2300 2301 2302 2303 2304 | variable instead of retrieving the string again. Fixes [Bug 835289]. * doc/OpenFileChnl.3: Added description of the behaviour of Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command | | | 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 | variable instead of retrieving the string again. Fixes [Bug 835289]. * doc/OpenFileChnl.3: Added description of the behaviour of Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug 934511]. * doc/CrtCommand.3: Added note that the arguments given to the command proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch 414778]. * doc/ChnlStack.3: Removed the declaration that the interp argument to Tcl_(un)StackChannel can be NULL. This fixes [Bug 881220], reported by Marco Maggi <marcomaggi@users.sourceforge.net>. * tests/socket.test: Accepted two new testcases by Stuart Casoff |
| ︙ | ︙ | |||
2869 2870 2871 2872 2873 2874 2875 | rejecting the "fix" for "Bug" 945570. Tcl_FSSeek() needs the values of SEEK_SET, etc. and too many extensions rely on tcl.h providing stdio.h for them. 2004-06-02 Jeff Hobbs <jeffh@ActiveState.com> * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA | | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 | rejecting the "fix" for "Bug" 945570. Tcl_FSSeek() needs the values of SEEK_SET, etc. and too many extensions rely on tcl.h providing stdio.h for them. 2004-06-02 Jeff Hobbs <jeffh@ActiveState.com> * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8. Adjunct to 2004-04-07 fix. 2004-06-02 David Gravereaux <davygrvy@pobox.com> * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing to ensure we get an exitcode. The windows pipe channel driver doesn't differentiate between a blocking and non-blocking close just yet, but |
| ︙ | ︙ |
Changes to ChangeLog.2005.
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 | * generic/tclInt.h (TclGetTruthValueFromObj): New routine. * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected | | | 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 | * generic/tclInt.h (TclGetTruthValueFromObj): New routine. * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected values like "47" and "0xAC" to be accepted as booleans. * generic/tclLiteral.c: Disabled the code that forces some literals into the "int" Tcl_ObjType during registration. We can re-enable it if this change causes trouble, but it seems more sensible to let Tcl's "on-demand" shimmering rule, and not try to pre-guess things. 2005-04-20 Kevin B. Kenny <kennykb@acm.org> |
| ︙ | ︙ |
Changes to README.md.
1 2 3 4 5 6 7 | # README: Tcl This is the **Tcl 8.7a4** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # README: Tcl This is the **Tcl 8.7a4** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-branch) [](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+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) |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | When paired with the Tk toolkit, Tcl provides the fastest and most powerful way to create GUI applications that run on PCs, Unix, and Mac OS X. Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. Tcl is maintained, enhanced, and distributed freely by the Tcl community. Source code development and tracking of bug reports and feature requests | | | | | 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 | When paired with the Tk toolkit, Tcl provides the fastest and most powerful way to create GUI applications that run on PCs, Unix, and Mac OS X. Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. Tcl is maintained, enhanced, and distributed freely by the Tcl community. Source code development and tracking of bug reports and feature requests take place at [core.tcl-lang.org](https://core.tcl-lang.org/). Tcl/Tk release and mailing list services are [hosted by SourceForge](https://sourceforge.net/projects/tcl/) with the Tcl Developer Xchange hosted at [www.tcl-lang.org](https://www.tcl-lang.org). Tcl is a freely available open-source package. You can do virtually anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. ## <a id="doc">2.</a> Documentation Extensive documentation is available on our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/8.7.html). Detailed release notes can be found at the [file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) by clicking on the relevant version. Information about Tcl itself can be found at the [Developer |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | ## <a id="build">3.</a> Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). ## <a id="devtools">4.</a> Development tools | | | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | ## <a id="build">3.</a> Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). ## <a id="devtools">4.</a> Development tools ActiveState produces a high-quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, static code checker, single-file wrapping utility, bytecode compiler, and more. More information can be found at http://www.ActiveState.com/Tcl ## <a id="complangtcl">5.</a> Tcl newsgroup There is a USENET newsgroup, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. ## <a id="wiki">6.</a> Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. |
| ︙ | ︙ |
Changes to changes.
| ︙ | ︙ | |||
2303 2304 2305 2306 2307 2308 2309 | existing files. (JH) 9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect to the standard channel, do not increment the refcount. The channel can be NULL if there is for example no standard input. (JL) 9/6/96 (portability improvement) Changed parsing of backslash sequences | | | 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 | existing files. (JH) 9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect to the standard channel, do not increment the refcount. The channel can be NULL if there is for example no standard input. (JL) 9/6/96 (portability improvement) Changed parsing of backslash sequences like \n to translate directly to absolute values like 0xA instead of letting the compiler do the translation. This guarantees that the translation is done the same everywhere. (JO) 9/9/96 (bug fix) If channel is opened and not associated with any interpreter, but Tcl decides to use it as one of the standard channels, it became impossible to close the channel with Tcl_Close -- instead you had to call Tcl_UnregisterChannel. Fixed now so that it's safe to call |
| ︙ | ︙ | |||
8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 | 2019-10-28 (bug)[bcd100] bad fs cache when system encoding changes (coulter) 2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres) - Released 8.6.10, Nov 21, 2019 - details at http://core.tcl-lang.org/tcl/ - Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10, plus the following, which focuses on the high-level feature changes in this changeset (new minor version) rather than bug fixes: 2017-11-01 (bug)[3c32a3] crash deleting class mixed into instance (coulter) 2017-11-03 [TIP 345] eliminate the encoding 'identity' (porter) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 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 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 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 |
2019-10-28 (bug)[bcd100] bad fs cache when system encoding changes (coulter)
2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres)
- Released 8.6.10, Nov 21, 2019 - details at http://core.tcl-lang.org/tcl/ -
2019-12-03 (bug)[3cd9be] Corner case in surrogate handling (nijtmans)
2019-12-09 (new) Add tcltest::(Setup|Eval|Cleanup|)Test (coulter,sebres)
=> tcltest 2.5.2
2019-12-12 (new) Add 3 libtommath functions to stub table (nijtmans)
2019-12-23 (bug)[ce3b9f] compilation errors with clang, windows msys2 (nijtmans)
2019-12-27 (bug)[1de6b0] [expr 1e2147483648] => 0.0 (kbk)
2020-01-04 (bug)[912886] tis-620 encoding fails to load (coulter)
2020-01-13 (bug)[0b9332] Win: support system encoding init to utf-8 (jedliÄka)
2020-01-17 (bug)[8cd2fe] [unload] corrupted list of loaded packages (berc)
2020-01-17 (bug)[5d989f] segfault in lsort for large list length (sebres)
2020-01-30 (bug) Reset WSAGetLastError()/errno in channel close (nijtmans)
2020-02-17 (bug) Win: avoid create of legacy error-vars on init phase (sebres)
2020-02-25 (bug) release refs when setting class's superclasses fails (dkf)
2020-02-26 (bug) C++ compiler compatibility for registry and dde (nijtmans)
=> registry 1.4.3
=> dde 1.3.5
2020-03-05 (new) Update to Unicode-13 (nijtmans)
2020-03-16 (bug)[8f89e2] Win: env var encoding, env-2.5 (sebres, nijtmans)
2020-03-27 (bug)[767e07] Tcl_Get(Range|UniChar) validate index inputs (nijtmans)
2020-03-28 (bug)[8edfce] [binary encode base64] & multi-byte wrapchars (dgp)
2020-03-28 (bug)[ffeb20] [binary decode base64] ignore invalid chars (dgp)
See RFC 2045
*** POTENTIAL INCOMPATIBILITY ***
2020-03-31 (bug)[b8e82d] some -maxlen values break uuencode round trip (dgp)
*** POTENTIAL INCOMPATIBILITY ***
2020-04-01 (bug)[f58371] Fileevent run in proper thread (bron,sebres)
2020-04-13 (bug)[afa4b2] TclNeedSpace bug; tests util-8.5 .. util-8.11 (dgp)
2020-04-13 (bug)[085913] Tcl_DStringAppendElement # quoting precision (dgp)
*** POTENTIAL INCOMPATIBILITY ***
2020-04-13 (bug)[a7f685] test util-5.52 (dgp)
2020-04-13 (bug)[c61818] Tcl_UtfPrev regression (dgp)
2020-04-15 (bug)[8af92d] zlib transform issue, bad inflate (sebres)
2020-04-16 (bug)[5e6346] Tcl_UtfPrev handling of overlong sequences (dgp)
2020-04-27 (bug)[45ca23] [string tolower] inconsistency (dgp)
2020-04-30 (bug)[da2352] init [info hostname] with DNS, not NetBIOS (nadkarni)
2020-05-11 (bug)[d402ff] Win32 potential crash when using main() (werner)
2020-05-13 (bug)[81242a] revised documentation for Tcl_UtfAtIndex() (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2020-05-13 (bug)[ed2980] Tcl_UtfToUniChar reads > TCL_UTF_MAX bytes (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2020-06-02 (bug) prevent segfault in parser (sebres)
2020-06-21 (bug)[f81bec] http POST a binary file (alakendu,nash)
=> http 2.9.2
2020-06-23 (bug)[41c985] auto_path nonsense in Safe Base (nash)
2020-06-24 (bug)[f70ce1] zlib multi-stream inflate acts only on first (sebres)
2020-07-09 (bug)[a1bd37] [clock scan] new ISO format (clock-34.(19-24)) (sebres)
*** POTENTIAL INCOMPATIBILITY ***
2020-07-10 (bug)[501974] [clock scan] +time zone (clock-34.(53-68)) (sebres)
*** POTENTIAL INCOMPATIBILITY ***
2020-07-15 (bug)[3c6e47] compiled [lappend] performance, avoid copy (sebres)
2020-07-16 (bug)[5bbd04] Fix index underflow (schwab)
2020-07-27 (bug)[cb0373] http::geturl -keepalive fixes (nash)
=> http 2.9.3
2020-08-10 (bug)[29e884] cmd resolution cycle (namespace-57.0) (coulter,sebres)
2020-08-12 (bug)[e87000] Tcl_BadChannelOption tolerate NULL (werner,nijtmans)
2020-08-31 (TIP #581) disfavor Master/Slave terminology (nijtmans)
=> opt 0.4.8
2020-09-11 (bug)[3bc0f4] UBSan complains about body.chars[] usage (nijtmans)
2020-09-17 (bug)[835c93] Support TIP 525 exit code for -singleproc 1 (nijtmans)
=> tcltest 2.5.3
2020-09-25 (new) force -eofchar \032 when evaluating library scripts (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2020-09-29 (bug)[0063cb] http::geturl -headers must be dict (oehlmann,nijtmans)
2020-10-19 (bug)[cb4582] Update install-sh script (stu,nijtmans)
2020-10-22 (bug)[c97593] Usage of gnu_printf in latest mingw-w64 (nijtmans)
2020-10-26 (new)[48898a] improve error message consistency (stu)
*** POTENTIAL INCOMPATIBILITY ***
2020-11-06 (new) revised case of module names (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2020-12-10 (bug)[ed5be7] Win: recognize "comx:" as serial port (oehlmann)
2020-12-11 (new) support for msys2, Big Sur (nijtmans)
=> platform 1.0.15
2020-12-23 tzdata updated to Olson's tzdata2020e (jima)
- Released 8.6.11, Dec 31, 2020 - details at http://core.tcl-lang.org/tcl/ -
Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10,
plus the following, which focuses on the high-level feature changes
in this changeset (new minor version) rather than bug fixes:
2017-11-01 (bug)[3c32a3] crash deleting class mixed into instance (coulter)
2017-11-03 [TIP 345] eliminate the encoding 'identity' (porter)
|
| ︙ | ︙ | |||
9116 9117 9118 9119 9120 9121 9122 | 2019-06-28 [TIP 547] New encodings utf-16, ucs-2 2019-09-14 [TIP 414] Tcl_InitSubsystems() 2019-09-14 [TIP 548] wchar_t conversion functions - Released 8.7a3, Nov 21, 2019 --- http://core.tcl-lang.org/tcl/ for details - | > > > > > > | 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 | 2019-06-28 [TIP 547] New encodings utf-16, ucs-2 2019-09-14 [TIP 414] Tcl_InitSubsystems() 2019-09-14 [TIP 548] wchar_t conversion functions - Released 8.7a3, Nov 21, 2019 --- http://core.tcl-lang.org/tcl/ for details - Changes to 8.7a5 include all changes to the 8.6 line through 8.6.11, plus the following, which focuses on the high-level feature changes in this changeset (new minor version) rather than bug fixes: - Released 8.7a5, Jan 21, 2021 --- http://core.tcl-lang.org/tcl/ for details - |
Changes to compat/fake-rfc2553.c.
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
| | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
*res = malloc_ai(port, htonl(0x7F000001), hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (inet_aton(hostname, &in)) {
*res = malloc_ai(port, in.s_addr, hints);
|
| ︙ | ︙ |
Changes to compat/string.h.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | * The following #include is needed to define size_t. (This used to include * sys/stdtypes.h but that doesn't exist on older versions of SunOS, e.g. * 4.0.2, so I'm trying sys/types.h now.... hopefully it exists everywhere) */ #include <sys/types.h> | < < < < | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | * The following #include is needed to define size_t. (This used to include * sys/stdtypes.h but that doesn't exist on older versions of SunOS, e.g. * 4.0.2, so I'm trying sys/types.h now.... hopefully it exists everywhere) */ #include <sys/types.h> extern void * memchr(const void *s, int c, size_t n); extern int memcmp(const void *s1, const void *s2, size_t n); extern void * memcpy(void *t, const void *f, size_t n); #ifdef NO_MEMMOVE #define memmove(d,s,n) (bcopy((s), (d), (n))) #else extern char * memmove(void *t, const void *f, size_t n); #endif extern void * memset(void *s, int c, size_t n); extern int strcasecmp(const char *s1, const char *s2); extern char * strcat(char *dst, const char *src); extern char * strchr(const char *string, int c); extern int strcmp(const char *s1, const char *s2); extern char * strcpy(char *dst, const char *src); extern size_t strcspn(const char *string, const char *chars); |
| ︙ | ︙ |
Changes to compat/strstr.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | * None. * *---------------------------------------------------------------------- */ char * strstr( | | | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
char *
strstr(
const char *string, /* String to search. */
const char *substring) /* Substring to try to find in string. */
{
const char *a, *b;
/*
* First scan quickly through the two strings looking for a
* single-character match. When it's found, then compare the rest of the
* substring.
*/
b = substring;
if (*b == 0) {
return (char *)string;
}
for ( ; *string != 0; string += 1) {
if (*string != *b) {
continue;
}
a = string;
while (1) {
if (*b == 0) {
return (char *)string;
}
if (*a++ != *b++) {
break;
}
}
b = substring;
}
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/crypt.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | The new AES encryption added on Zip format by Winzip (see the page http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong Encryption is not supported. */ #define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) | < < < < < < > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
The new AES encryption added on Zip format by Winzip (see the page
http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong
Encryption is not supported.
*/
#define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8))
/***********************************************************************
* Return the next byte in the pseudo-random sequence
*/
static int decrypt_byte(unsigned long* pkeys, const z_crc_t* pcrc_32_tab)
{
unsigned temp; /* POTENTIAL BUG: temp*(temp^1) may overflow in an
* unpredictable manner on 16-bit systems; not a problem
* with any known compiler so far, though */
(void)pcrc_32_tab;
temp = ((unsigned)(*(pkeys+2)) & 0xffff) | 2;
return (int)(((temp * (temp ^ 1)) >> 8) & 0xff);
}
/***********************************************************************
* Update the encryption keys with the next byte of plain text
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc10/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc11/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc12/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc14/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc9/zlibvc.sln.
| ︙ | ︙ |
Name change from doc/CrtSlave.3 to doc/CrtAlias.3.
1 2 3 4 5 6 | '\" '\" 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. '\" | | | > > > | | > > > > > > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
'\"
'\" Copyright (c) 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_MakeSafe, Tcl_CreateChild, Tcl_CreateSlave, Tcl_GetChild, Tcl_GetSlave, Tcl_GetParent, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, 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
int
\fBTcl_MakeSafe\fR(\fIinterp\fR)
.sp
Tcl_Interp *
\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR)
.sp
Tcl_Interp *
\fBTcl_GetSlave\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetChild\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetMaster\fR(\fIinterp\fR)
.sp
Tcl_Interp *
\fBTcl_GetParent\fR(\fIinterp\fR)
.sp
int
\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR)
.sp
int
\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_GetAlias\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
argcPtr, argvPtr\fR)
.sp
int
\fBTcl_GetAliasObj\fR(\fIinterp, childCmd, targetInterpPtr, targetCmdPtr,
objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR)
.sp
int
\fBTcl_HideCommand\fR(\fIinterp, cmdName, hiddenCmdName\fR)
.SH ARGUMENTS
.AS "const char *const" **targetInterpPtr out
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
.AP "const char" *name in
Name of child interpreter to create or manipulate.
.AP int isSafe in
If non-zero, a
.QW safe
child that is suitable for running untrusted code
is created, otherwise a trusted child is created.
.AP Tcl_Interp *childInterp in
Interpreter to use for creating the source command for an alias (see
below).
.AP "const char" *childCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "const char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | facility from inside C programs. They enable managing multiple interpreters in a hierarchical relationship, and the management of aliases, commands that when invoked in one interpreter execute a command in another interpreter. The return value for those procedures that return an \fBint\fR is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned then the interpreter's result contains an error message. .PP | | | | | | | > > | | | | > > | | > > | | | | | | | | | | 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 | facility from inside C programs. They enable managing multiple interpreters in a hierarchical relationship, and the management of aliases, commands that when invoked in one interpreter execute a command in another interpreter. The return value for those procedures that return an \fBint\fR is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned then the interpreter's result contains an error message. .PP \fBTcl_CreateChild\fR creates a new interpreter as a child of \fIinterp\fR. It also creates a child command named \fIname\fR in \fIinterp\fR which allows \fIinterp\fR to manipulate the new child. If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl code has access to all the Tcl commands. If it is \fB1\fR, the command creates a .QW safe child in which Tcl code has access only to set of Tcl commands defined as .QW "Safe Tcl" ; see the manual entry for the Tcl \fBinterp\fR command for details. If the creation of the new child interpreter failed, \fBNULL\fR is returned. .PP \fBTcl_CreateSlave\fR is a synonym for \fBTcl_CreateChild\fR. .PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is .QW safe (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), \fB0\fR otherwise. .PP \fBTcl_MakeSafe\fR marks \fIinterp\fR as .QW safe , so that future calls to \fBTcl_IsSafe\fR will return 1. It also removes all known potentially-unsafe core functionality (both commands and variables) from \fIinterp\fR. However, it cannot know what parts of an extension or application are safe and does not make any attempt to remove those parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. Callers will want to take care with their use of \fBTcl_MakeSafe\fR to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR may be a better choice, since it creates interpreters in a known-safe state. .PP \fBTcl_GetChild\fR returns a pointer to a child interpreter of \fIinterp\fR. The child interpreter is identified by \fIname\fR. If no such child interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetSlave\fR is a synonym for \fBTcl_GetChild\fR. .PP \fBTcl_GetParent\fR returns a pointer to the parent interpreter of \fIinterp\fR. If \fIinterp\fR has no parent (it is a top-level interpreter) then \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR is a synonym for \fBTcl_GetParent\fR. .PP \fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR the relative path between \fIinterp\fR and \fIchildInterp\fR; \fIchildInterp\fR must be a child of \fIinterp\fR. If the computation of the relative path succeeds, \fBTCL_OK\fR is returned, else \fBTCL_ERROR\fR is returned and an error message is stored as the result of \fIinterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIchildCmd\fR in \fIchildInterp\fR that when invoked, will cause the command \fItargetCmd\fR to be invoked in \fItargetInterp\fR. The arguments specified by the strings contained in \fIargv\fR are always prepended to any arguments supplied in the invocation of \fIchildCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if it fails; in that case, an error message is left in the value result of \fIchildInterp\fR. Note that there are no restrictions on the ancestry relationship (as created by \fBTcl_CreateChild\fR) between \fIchildInterp\fR and \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 |
| ︙ | ︙ | |||
229 230 231 232 233 234 235 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, | | | 244 245 246 247 248 249 250 251 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, parent, child |
Changes to doc/CrtChannel.3.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 | outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the | > | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP \fBTcl_NotifyChannel\fR is called by a channel driver to indicate to the generic layer that the events specified by \fImask\fR have occurred on the channel. Channel drivers are responsible for invoking this function whenever the channel handlers need to be called for the channel (or other pending tasks like a write flush should be performed). See \fBWATCHPROC\fR below for more details. .PP \fBTcl_BadChannelOption\fR is called from driver specific \fIsetOptionProc\fR or \fIgetOptionProc\fR to generate a complete error message. .PP \fBTcl_ChannelBuffered\fR returns the number of bytes of input currently buffered in the internal buffer (push back area) of the |
| ︙ | ︙ |
Changes to doc/CrtTrace.3.
1 2 3 | '\" '\" Copyright (c) 1989-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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 Kevin B. Kenny <kennykb@acm.org>. 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 Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/DumpActiveMemory.3.
1 | '\" | | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans. '\" Copyright (c) 2000 Scriptics Corporation. '\" All rights reserved. '\" .TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory allocation interface |
| ︙ | ︙ |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
410 411 412 413 414 415 416 | accumulates the return values in a list which is returned to the caller (with a reference count of 0). .PP \fBTcl_FSEvalFileEx\fR reads the file given by \fIpathPtr\fR using the encoding identified by \fIencodingName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. | | | | 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 | accumulates the return values in a list which is returned to the caller (with a reference count of 0). .PP \fBTcl_FSEvalFileEx\fR reads the file given by \fIpathPtr\fR using the encoding identified by \fIencodingName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If \fIencodingName\fR is NULL, the utf-8 encoding is used for reading the file contents. If the file could not be read then a Tcl error is returned to describe why the file could not be read. The eofchar for files is .QW \e32 (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use .QW \e032 or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . \fBTcl_FSEvalFile\fR is a simpler version of \fBTcl_FSEvalFileEx\fR that always uses the utf-8 encoding when reading the file. .PP \fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and returns the addresses of two procedures within that file, if they are defined. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. If that filesystem does not implement this function (most virtual filesystems will not, because of OS limitations |
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a | | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 | .PP The result should be a list of volumes added by this filesystem, or NULL (or an empty list) if no volumes are provided. The result value is considered to be owned by the filesystem (not by Tcl's core), but should be given a reference count for Tcl. Tcl will use the contents of the list and then decrement that reference count. This allows filesystems to choose whether they actually want to retain a .QW "global list" of volumes or not (if not, they generate the list on the fly and pass it to Tcl with a reference count of 1 and then forget about the list, if yes, then they simply increment the reference count of their global list and pass it to Tcl which will copy the contents and then decrement the count back to where it was). .PP Therefore, Tcl considers return values from this proc to be read-only. .SS FILEATTRSTRINGSPROC .PP Function to list all attribute strings which are valid for this |
| ︙ | ︙ |
Changes to doc/GetHostName.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" .TH Tcl_GetHostName 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetHostName \- get the name of the local host |
| ︙ | ︙ |
Changes to doc/GetIndex.3.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this value is used to search through \fItablePtr\fR. | > | > | > | | > | 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 | .SH ARGUMENTS .AS "const char" *structTablePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this value is used to search through \fItablePtr\fR. If the \fBTCL_INDEX_TEMP_TABLE\fR flag is not specified, the internal representation is modified to hold the index of the matching table entry. .AP "const char *const" *tablePtr in An array of null-terminated strings. The end of the array is marked by a NULL string pointer. Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, references to the \fItablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array. .AP "const void" *structTablePtr in An array of arbitrary type, typically some \fBstruct\fR type. The first member of the structure must be a null-terminated string. The size of the structure is given by \fIoffset\fR. Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified, references to the \fIstructTablePtr\fR may be retained in the internal representation of \fIobjPtr\fR, so this should represent the address of a statically-allocated array of structures. .AP int offset in The offset to add to structTablePtr to get to the next entry. The end of the array is marked by a NULL string pointer. .AP "const char" *msg in Null-terminated string describing what is being looked up, such as \fBoption\fR. This string is included in error messages. .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR and \fBTCL_INDEX_TEMP_TABLE\fR. .AP int *indexPtr out The index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. .BE .SH DESCRIPTION .PP These procedures provide an efficient way for looking up keywords, |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's result if \fIinterp\fR is not NULL. \fIMsg\fR is included in the error message to indicate what was being looked up. For example, if \fImsg\fR is \fBoption\fR the error message will have a form like .QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" . .PP | > | > > | | 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 | If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's result if \fIinterp\fR is not NULL. \fIMsg\fR is included in the error message to indicate what was being looked up. For example, if \fImsg\fR is \fBoption\fR the error message will have a form like .QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" . .PP If the \fBTCL_INDEX_TEMP_TABLE\fR was not specified, when \fBTcl_GetIndexFromObj\fR completes successfully it modifies the internal representation of \fIobjPtr\fR to hold the address of the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR arguments (e.g. during a reinvocation of a Tcl command), it returns the matching index immediately without having to redo the lookup operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. If the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP \fBTcl_GetIndexFromObjStruct\fR works just like \fBTcl_GetIndexFromObj\fR, except that instead of treating \fItablePtr\fR as an array of string pointers, it treats it as a pointer to the first string in a series of strings that have |
| ︙ | ︙ |
Changes to doc/GetStdChan.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/GetTime.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetTime 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/Init.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" .TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Init \- find and source initialization script |
| ︙ | ︙ |
Changes to doc/Limit.3.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | the interpreter to permit it to continue processing longer. .PP When a limit is exceeded (and the callbacks have run; the order of execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | the interpreter to permit it to continue processing longer. .PP When a limit is exceeded (and the callbacks have run; the order of execution of the callbacks is unspecified) execution in the limited interpreter is stopped by raising an error and setting a flag that prevents the \fBcatch\fR command in that interpreter from trapping that error. It is up to the context that started execution in that interpreter (typically the main interpreter) to handle the error. .SH "LIMIT CHECKING API" .PP To check the resource limits for an interpreter, call \fBTcl_LimitCheck\fR, which returns \fBTCL_OK\fR if the limit was not exceeded (after processing callbacks) and \fBTCL_ERROR\fR if the limit was exceeded (in which case an error message is also placed in the interpreter result). That function should only be called when |
| ︙ | ︙ |
Changes to doc/ListObj.3.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, | | > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, they return an empty value. If \fIobjv\fR is NULL, the resulting list contains 0 elements, with reserved space in an internal representation for \fIobjc\fR more elements (to avoid its reallocation later). The new value's string representation is left invalid. The two procedures increment the reference counts of the elements in \fIobjc\fR since the list value now refers to them. The new list value returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of |
| ︙ | ︙ |
Changes to doc/NRE.3.
1 | .\" | | | | 1 2 3 4 5 6 7 8 9 10 | .\" .\" Copyright (c) 2008 Kevin B. Kenny. .\" Copyright (c) 2018 Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | implement looping and sequencing constructs using the function stack. .PP .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT | | | | 228 229 230 231 232 233 234 235 236 | implement looping and sequencing constructs using the function stack. .PP .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT Copyright \(co 2008 Kevin B. Kenny. Copyright \(co 2018 Nathan Coulter. |
Changes to doc/ParseCmd.3.
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | \fBTCL_TOKEN_TEXT\fR . The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR . | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | \fBTCL_TOKEN_TEXT\fR . The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR . The token describes a backslash sequence such as \fB\en\fR or \fB\e0xA3\fR. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_COMMAND\fR . The token describes a command whose result must be substituted into the word. The token includes the square brackets that surround the command. The \fInumComponents\fR field is always 0 (the nested command |
| ︙ | ︙ |
Changes to doc/SaveResult.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" |
| ︙ | ︙ |
Changes to doc/SourceRCFile.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" .TH Tcl_SourceRCFile 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SourceRCFile \- source the Tcl rc file |
| ︙ | ︙ |
Changes to doc/StdChannels.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2001 ActiveState Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "Standard Channels" 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/TCL_MEM_DEBUG.3.
1 | '\" | | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans. '\" Copyright (c) 2000 Scriptics Corporation. '\" All rights reserved. '\" .TH TCL_MEM_DEBUG 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME TCL_MEM_DEBUG \- Compile-time flag to enable Tcl memory debugging |
| ︙ | ︙ |
Changes to doc/Tcl.n.
| ︙ | ︙ | |||
219 220 221 222 223 224 225 | 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. .RS .PP | | > > > | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | 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. .RS .PP The range U+00D800\(enU+00DFFF is reserved for surrogates, which are illegal on their own. Therefore, such sequences will result in the replacement character U+FFFD. Surrogate pairs should be encoded as single \e\fBU\fIhhhhhhhh\fR character. .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 |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | .PP \fBTcl_Main\fR is not provided by the public interface of Tcl's stub library. Programs that call \fBTcl_Main\fR must be linked against the standard Tcl library. Extensions (stub-enabled or not) are not intended to call \fBTcl_Main\fR. .PP \fBTcl_Main\fR is not thread-safe. It should only be called by a single main thread of a multi-threaded application. This restriction is not a problem with normal use described above. .PP \fBTcl_Main\fR and therefore all applications based upon it, like \fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard channels to their default values. See \fBTcl_StandardChannels\fR for more information. .PP |
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | and the stored encoding name is written to space pointed to by \fIencodingPtr\fR, when that is not NULL. .PP The file name and encoding values managed by the routines \fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR are stored per-thread. Although the storage and retrieval functions of these routines work in any thread, only those | | | | 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 | and the stored encoding name is written to space pointed to by \fIencodingPtr\fR, when that is not NULL. .PP The file name and encoding values managed by the routines \fBTcl_SetStartupScript\fR and \fBTcl_GetStartupScript\fR are stored per-thread. Although the storage and retrieval functions of these routines work in any thread, only those calls in the same main thread as \fBTcl_Main\fR can have any influence on it. .PP The caller of \fBTcl_Main\fR may call \fBTcl_SetStartupScript\fR first to establish its desired startup script. If \fBTcl_Main\fR finds that no such startup script has been established, it consults the first few arguments in \fIargv\fR. If they match ?\fB\-encoding \fIname\fR? \fIfileName\fR, where \fIfileName\fR does not begin with the character \fI\-\fR, then \fIfileName\fR is taken to be the name of a file containing a \fIstartup script\fR, and \fIname\fR is taken to be the name of the encoding of the contents of that file. \fBTcl_Main\fR then calls \fBTcl_SetStartupScript\fR with these values. .PP \fBTcl_Main\fR then defines in its main interpreter the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and \fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR. .PP When it has finished its own initialization, but before it processes commands, \fBTcl_Main\fR calls the procedure given by the \fIappInitProc\fR argument. This procedure provides a .QW hook |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls \fBTcl_GetStartupScript\fR to determine what startup script has been requested, if any. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR | | | | | 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 | details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR calls \fBTcl_GetStartupScript\fR to determine what startup script has been requested, if any. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR in the main interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated in the main interpreter. Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. The prompts and command evaluation results are written to the standard output channel only if the Tcl variable \fItcl_interactive\fR in the main interpreter holds a non-zero integer value. .PP \fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run. This allows, for example, Tk to be dynamically loaded and set its event loop. The event loop will run following the startup script. If you are in interactive mode, setting the main loop procedure will cause the prompt to become fileevent based and then the loop procedure is called. When the loop procedure returns in interactive mode, interactive operation |
| ︙ | ︙ |
Changes to doc/ToUpper.3.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 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_UtfToUpper 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/Utf.3.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP | > | > > | | | > > | | > > | > > > > > > > | | > > > > | | | 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 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP \fBTcl_UtfPrev\fR is used to step backward through but not beyond the UTF-8 string that begins at \fIstart\fR. If the UTF-8 string is made up entirely of complete and well-formed characters, and \fIsrc\fR points to the lead byte of one of those characters (or to the location one byte past the end of the string), then repeated calls of \fBTcl_UtfPrev\fR will return pointers to the lead bytes of each character in the string, one character at a time, terminating when it returns \fIstart\fR. .PP When the conditions of completeness and well-formedness may not be satisfied, a more precise description of the function of \fBTcl_UtfPrev\fR is necessary. It always returns a pointer greater than or equal to \fIstart\fR; that is, always a pointer to a location in the string. It always returns a pointer to a byte that begins a character when scanning for characters beginning from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it always returns a pointer less than \fIsrc\fR and greater than or equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins at the returned pointer is the first one that either includes the byte \fIsrc[-1]\fR, or might include it if the right trail bytes are present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte \fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. If a negative \fIindex\fR is given or \fIindex\fR points to the second half of a surrogate pair, it returns -1. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling \fBTcl_UtfToUniChar\fR \fIindex\fR times, except if that would return a pointer to the second byte of a valid 4-byte UTF-8 sequence, in which case, \fBTcl_UtfToUniChar\fR will be called once more to find the end of the sequence. If a negative \fIindex\fR is given, the returned pointer points to the first character in the source string. .PP \fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl commands. It parses a backslash sequence and stores the properly formed UTF-8 character represented by the backslash sequence in the output buffer \fIdst\fR. At most 4 bytes are stored in the buffer. \fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number of bytes in the backslash sequence, including the backslash character. |
| ︙ | ︙ |
Changes to doc/abstract.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::abstract \- a class that does not allow direct instances of itself .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 oo::abstract \- a class that does not allow direct instances of itself .SH SYNOPSIS .nf package require tcl::oo \fBoo::abstract\fI method \fR?\fIarg ...\fR? .fi .SH "CLASS HIERARCHY" .nf \fBoo::object\fR \(-> \fBoo::class\fR |
| ︙ | ︙ |
Changes to doc/binary.n.
1 | '\" | | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2008 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 binary n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | newline character, .QW \en . .PP During decoding, the following options are supported: .TP \fB\-strict\fR . | | > > | > | | | | | > > > | < | > > | | 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 |
newline character,
.QW \en .
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters any characters
that are not strictly part of the encoding itself. Otherwise it ignores them.
RFC 2045 calls for base64 decoders to be non-strict.
.RE
.TP
\fBhex\fR
.
The \fBhex\fR binary encoding converts each byte to a pair of hexadecimal
digits in big-endian form.
.RS
.PP
No options are supported during encoding. During decoding, the following
options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters whitespace characters.
Otherwise it ignores them.
.RE
.TP
\fBuuencode\fR
.
The \fBuuencode\fR binary encoding used to be common for transfer of data
between Unix systems and on USENET, but is less common these days, having been
largely superseded by the \fBbase64\fR binary encoding.
.RS
.PP
During encoding, the following options are supported (though changing them may
produce files that other implementations of decoders cannot process):
.TP
\fB\-maxlen \fIlength\fR
.
Indicates the maximum number of characters to produce for each encoded line.
The valid range is 5 to 85. Line lengths outside that range cannot be
accommodated by the encoding format. The default value is 61.
.TP
\fB\-wrapchar \fIcharacter\fR
.
Indicates the character(s) to use to mark the end of each encoded line.
Acceptable values are a sequence of zero or more characters from the
set { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed
by zero or one newline \\x0A (LF). Any other values are rejected because
they would generate encoded text that could not be decoded. The default value
is a single newline.
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters anything
outside of the standard encoding format. Without this option, the
decoder tolerates some deviations, mostly to forgive reflows of lines
between the encoder and decoder.
.PP
Note that neither the encoder nor the decoder handle the header and footer of
the uuencode format.
.RE
.SH "BINARY FORMAT"
.PP
The \fBbinary format\fR command generates a binary string whose layout
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 758 759 760 761 762 763 764 | .CS \fBbinary scan\fR \ex70\ex87\ex05 B5B* var1 var2 .CE .PP will return \fB2\fR with \fB01110\fR stored in \fIvar1\fR and \fB1000011100000101\fR stored in \fIvar2\fR. .RE .IP \fBH\fR 5 The data is turned into a string of \fIcount\fR hexadecimal digits in high-to-low order represented as a sequence of characters in the set .QW 0123456789abcdef . The data bytes are scanned in first to last order with the hex digits being taken in high-to-low order within each byte. Any extra bits in the last byte are ignored. If \fIcount\fR is | > > > > > > > > > | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 | .CS \fBbinary scan\fR \ex70\ex87\ex05 B5B* var1 var2 .CE .PP will return \fB2\fR with \fB01110\fR stored in \fIvar1\fR and \fB1000011100000101\fR stored in \fIvar2\fR. .RE .IP \fBC\fR 5 This form is similar to \fBA\fR, except that it scans the data from start and terminates at the first null (C string semantics). For example, .RS .CS \fBbinary scan\fR "abc\e000efghi" C* var1 .CE will return \fB1\fR with \fBabc\fR stored in \fIvar1\fR. .RE .IP \fBH\fR 5 The data is turned into a string of \fIcount\fR hexadecimal digits in high-to-low order represented as a sequence of characters in the set .QW 0123456789abcdef . The data bytes are scanned in first to last order with the hex digits being taken in high-to-low order within each byte. Any extra bits in the last byte are ignored. If \fIcount\fR is |
| ︙ | ︙ |
Changes to doc/callback.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME callback, mymethod \- generate callbacks to methods .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 callback, mymethod \- generate callbacks to methods .SH SYNOPSIS .nf package require tcl::oo \fBcallback\fR \fImethodName\fR ?\fIarg ...\fR? \fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION The \fBcallback\fR command, |
| ︙ | ︙ |
Changes to doc/chan.n.
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
operating system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
| | | | 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 |
operating system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\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.
For output, the end-of-file character is output when the channel is
closed. If \fIchar\fR is the empty string, then there is no special
end of file character marker. For read-write channels, a two-element
list specifies the end of file marker for input and output,
respectively. As a convenience, when setting the end-of-file
character for a read-write channel you can specify a single value that
will apply to both reading and writing. When querying the end-of-file
character of a read-write channel, a two-element list will always be
returned. The default value for \fB\-eofchar\fR is the empty string
in all cases except for files under Windows. In that case the
\fB\-eofchar\fR is Control-z (\ex1A) for reading and the empty string
for writing.
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.
.TP
\fB\-translation\fR \fImode\fR
.TP
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
set f [open somefile.txt r+]
\fBchan configure\fR $f -encoding cp1252
set offset 0
\fI# Search for string "FOOBAR" in the file\fR
while {[\fBchan gets\fR $f line] >= 0} {
set idx [string first FOOBAR $line]
| | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
set f [open somefile.txt r+]
\fBchan configure\fR $f -encoding cp1252
set offset 0
\fI# Search for string "FOOBAR" in the file\fR
while {[\fBchan gets\fR $f line] >= 0} {
set idx [string first FOOBAR $line]
if {$idx >= 0} {
\fI# Found it; rewrite line\fR
\fBchan seek\fR $f [expr {$offset + $idx}]
\fBchan puts\fR -nonewline $f BARFOO
\fI# Skip to end of following line, and truncate\fR
\fBchan gets\fR $f
|
| ︙ | ︙ |
Changes to doc/class.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::class \- class of all classes .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 oo::class \- class of all classes .SH SYNOPSIS .nf package require tcl::oo \fBoo::class\fI method \fR?\fIarg ...\fR? .fi .SH "CLASS HIERARCHY" .nf \fBoo::object\fR \(-> \fBoo::class\fR |
| ︙ | ︙ |
Changes to doc/classvariable.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME classvariable \- create link from local variable to variable in class .SH SYNOPSIS .nf | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME classvariable \- create link from local variable to variable in class .SH SYNOPSIS .nf package require tcl::oo \fBclassvariable\fR \fIvariableName\fR ?\fI...\fR? .fi .BE .SH DESCRIPTION The \fBclassvariable\fR command is available within methods. It takes a series of one or more variable names and makes them available in the method's scope; |
| ︙ | ︙ |
Changes to doc/clock.n.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times .SH "SYNOPSIS" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times .SH "SYNOPSIS" package require \fBTcl 8.5-\fR .sp \fBclock add\fR \fItimeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? .sp \fBclock clicks\fR ?\fI\-option\fR? .sp \fBclock format\fR \fItimeVal\fR ?\fI\-option value\fR...? .sp |
| ︙ | ︙ | |||
467 468 469 470 471 472 473 | if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR | | | | | | | | 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 | if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and \fBclock format\fR commands. .TP \fB%a\fR On output, produces an abbreviation (\fIe.g.,\fR \fBMon\fR) for the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%A\fR On output, produces the full name (\fIe.g.,\fR \fBMonday\fR) of the day of the week in the given locale. On input, matches the name of the day of the week in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%b\fR On output, produces an abbreviation (\fIe.g.,\fR \fBJan\fR) for the name of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%B\fR On output, produces the full name (\fIe.g.,\fR \fBJanuary\fR) of the month in the given locale. On input, matches the name of the month in the given locale (in either abbreviated or full form, or any unique prefix of either form). .TP \fB%c\fR On output, produces a localized representation of date and time of day; the localized representation is expected to use the Gregorian calendar. On input, matches whatever \fB%c\fR produces. .TP \fB%C\fR On output, produces the number of the century in Indo-Arabic numerals. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the century. .TP \fB%d\fR On output, produces the number of the day of the month, as two decimal digits. On input, matches one or two digits, possibly with leading whitespace, that are expected to be the number of the day of the month. |
| ︙ | ︙ | |||
909 910 911 912 913 914 915 | 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 | | > | | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 | 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\fB:\fImm\fB:\fIss\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. 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 |
| ︙ | ︙ | |||
946 947 948 949 950 951 952 | 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" | | | 947 948 949 950 951 952 953 954 955 956 957 | 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: |
Changes to doc/copy.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::copy \- create copies of objects and classes .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 oo::copy \- create copies of objects and classes .SH SYNOPSIS .nf package require tcl::oo \fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR? .fi .BE .SH DESCRIPTION .PP The \fBoo::copy\fR command creates a copy of an object or class. It takes the |
| ︙ | ︙ |
Changes to doc/define.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::define, oo::objdefine \- define and configure classes and objects .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 oo::define, oo::objdefine \- 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? .fi .BE |
| ︙ | ︙ |
Changes to doc/dict.n.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | . This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. .VS TIP508 | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | . This appends the given string (or strings) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the appending operation. .VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . Return a new dictionary that contains each of the key/value mappings |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
The key rule only matches those key/value pairs whose keys match any
of the given patterns (in the style of \fBstring match\fR.)
.TP
\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR
.
The script rule tests for matching by assigning the key to the
\fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
The key rule only matches those key/value pairs whose keys match any
of the given patterns (in the style of \fBstring match\fR.)
.TP
\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR
.
The script rule tests for matching by assigning the key to the
\fIkeyVariable\fR and the value to the \fIvalueVariable\fR, and then evaluating
the given script which should result in a boolean value (with the
key/value pair only being included in the result of the \fBdict
filter\fR when a true value is returned.) Note that the first
argument after the rule selection word is a two-element list. If the
\fIscript\fR returns with a condition of \fBTCL_BREAK\fR, no further
key/value pairs are considered for inclusion in the resulting
dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false
result. The key/value pairs are tested in the order in which the keys
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. .VS TIP508 | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | not specified) to the value that the given key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the incrementing operation. .VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . This returns information (intended for display to people) about the |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 | to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. .VS TIP508 | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
to in the dictionary value contained in the given variable, writing
the resulting dictionary value back to that variable. Non-existent
keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list. The
updated dictionary value is returned.
.VS TIP508
If \fIdictionaryVariable\fR indicates an element that does not exist of an
array that has a default value set, the default value and will be used as the
value of the dictionary prior to the list-appending operation.
.VE TIP508
.TP
\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR
.
This command applies a transformation to each element of a dictionary,
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | . This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. .VS TIP508 | | | | | 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 | . This operation takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value insert/update operation. .VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . Return the number of key/value mappings in the given dictionary value. .TP \fBdict unset \fIdictionaryVariable key \fR?\fIkey ...\fR? . This operation (the companion to \fBdict set\fR) takes the name of a variable containing a dictionary value and places an updated dictionary value in that variable that does not contain a mapping for the given key. Where multiple keys are present, this describes a path through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the value remove operation. .VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . Execute the Tcl script in \fIbody\fR with the value for each \fIkey\fR (as found by reading the dictionary value in \fIdictionaryVariable\fR) mapped to the variable \fIvarName\fR. There may be multiple \fIkey\fR/\fIvarName\fR pairs. If a \fIkey\fR does not have a mapping, that corresponds to an unset \fIvarName\fR. When \fIbody\fR terminates, any changes made to the \fIvarName\fRs is reflected back to the dictionary within \fIdictionaryVariable\fR (unless \fIdictionaryVariable\fR itself becomes unreadable, when all updates are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the update operation. .VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; it is recommended that this command only be used in a local scope |
| ︙ | ︙ | |||
309 310 311 312 313 314 315 | \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | \fIdictionaryVariable\fR unreadable will make the updates to the dictionary be discarded, and this also happens if the contents of \fIdictionaryVariable\fR are adjusted so that the chain of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. .VS TIP508 If \fIdictionaryVariable\fR indicates an element that does not exist of an array that has a default value set, the default value and will be used as the value of the dictionary prior to the updating operation. .VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; it is recommended that this command only be used in a local scope |
| ︙ | ︙ |
Changes to doc/encoding.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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 |
| ︙ | ︙ |
Changes to doc/exec.n.
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | accept arguments with forward slashes only as option delimiters and backslashes only in paths. Any arguments to an application that specify a path name with forward slashes will not automatically be converted to use the backslash character. If an argument contains forward slashes as the path separator, it may or may not be recognized as a path name, depending on the program. .PP | < < < < < < < < < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | accept arguments with forward slashes only as option delimiters and backslashes only in paths. Any arguments to an application that specify a path name with forward slashes will not automatically be converted to use the backslash character. If an argument contains forward slashes as the path separator, it may or may not be recognized as a path name, depending on the program. .PP Two or more forward or backward slashes in a row in a path refer to a network path. For example, a simple concatenation of the root directory \fBc:/\fR with a subdirectory \fB/windows/system\fR will yield \fBc://windows/system\fR (two slashes together), which refers to the mount point called \fBsystem\fR on the machine called \fBwindows\fR (and the \fBc:/\fR is ignored), and is not equivalent to \fBc:/windows/system\fR, which describes a directory on the current computer. The \fBfile join\fR |
| ︙ | ︙ | |||
291 292 293 294 295 296 297 | application name, the following directories are automatically searched in order when attempting to locate the application: .IP \(bu 3 The directory from which the Tcl executable was loaded. .IP \(bu 3 The current directory. .IP \(bu 3 | | < < | | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | application name, the following directories are automatically searched in order when attempting to locate the application: .IP \(bu 3 The directory from which the Tcl executable was loaded. .IP \(bu 3 The current directory. .IP \(bu 3 The Windows 32-bit system directory. .IP \(bu 3 The Windows home directory. .IP \(bu 3 The directories listed in the path. .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. |
| ︙ | ︙ |
Changes to doc/expr.n.
1 2 3 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. 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 expr n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The \fIexpr\fR command concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators common to both Tcl and C, Tcl applies the same meaning and precedence as the corresponding C operators. The value of an expression is often a numeric result, either an integer or a floating-point value, but may also be a non-numeric value. |
| ︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 | non-numeric operands, string comparisons, and some additional operators not found in C. .PP When an expression evaluates to an integer, the value is the decimal form of the integer, and when an expression evaluates to a floating-point number, the value is the form produced by the \fB%g\fR format specifier of Tcl's \fBformat\fR command. .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is ignored. | > > > > > > < < < < < < < < < < < < < < < < | 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 | non-numeric operands, string comparisons, and some additional operators not found in C. .PP When an expression evaluates to an integer, the value is the decimal form of the integer, and when an expression evaluates to a floating-point number, the value is the form produced by the \fB%g\fR format specifier of Tcl's \fBformat\fR command. .PP .VS "TIP 582" You can use \fB#\fR at any point in the expression (except inside double quotes or braces) to start a comment. Comments last to the end of the line or the end of the expression, whichever comes first. .VE "TIP 582" .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is ignored. .PP An operand may be specified in any of the following ways: .IP [1] As a numeric value, either integer or floating-point. .IP [2] As a boolean value, using any form understood by \fBstring is\fR \fBboolean\fR. |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | .PP Below are some examples of simple expressions where the value of \fBa\fR is 3 and the value of \fBb\fR is 6. The command on the left side of each line produces the value on the right side. .PP .CS .ta 9c | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
.PP
Below are some examples of simple expressions where the value of \fBa\fR is 3
and the value of \fBb\fR is 6. The command on the left side of each line
produces the value on the right side.
.PP
.CS
.ta 9c
\fBexpr\fR {3.1 + $a} \fI6.1\fR
\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR
\fBexpr\fR {4*[llength "6 2"]} \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
.PP
\fBInteger value\fR
.PP
An integer operand may be specified in decimal (the normal case, the optional
first two characters are \fB0d\fR), binary
(the first two characters are \fB0b\fR), octal
(the first two characters are \fB0o\fR), or hexadecimal
(the first two characters are \fB0x\fR) form. For
compatibility with older Tcl releases, an operand that begins with \fB0\fR is
interpreted as an octal integer even if the second character is not \fBo\fR.
.PP
\fBFloating-point value\fR
.PP
A floating-point number may be specified in any of several
common decimal formats, and may use the decimal point \fB.\fR,
\fBe\fR or \fBE\fR for scientific notation, and
the sign characters \fB+\fR and \fB\-\fR. The
following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
The strings \fBInf\fR
and \fBNaN\fR, in any combination of case, are also recognized as floating point
values. An operand that doesn't have a numeric interpretation must be quoted
with either braces or with double quotes.
.PP
\fBBoolean value\fR
.PP
A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR,
or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR.
.PP
\fBDigit Separator\fR
.PP
Digits in any numeric value may be separated with one or more underscore
characters, "\fB_\fR", to improve readability. These separators may only
appear between digits. The separator may not appear at the start of a
numeric value, between the leading 0 and radix specifier, or at the
end of a numeric value. Here are some examples:
.PP
.CS
.ta 9c
\fBexpr\fR 100_000_000 \fI100000000\fR
\fBexpr\fR 0xffff_ffff \fI4294967295\fR
\fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR
.CE
.PP
.SS OPERATORS
.PP
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
|
| ︙ | ︙ | |||
239 240 241 242 243 244 245 | .PP As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature .QW "lazy evaluation" , which means that operands are not evaluated if they are not needed to determine the outcome. For example, in .PP .CS | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
.PP
As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature
.QW "lazy evaluation" ,
which means that operands are not evaluated if they are
not needed to determine the outcome. For example, in
.PP
.CS
\fBexpr\fR {$v?[a]:[b]}
.CE
.PP
only one of \fB[a]\fR or \fB[b]\fR is evaluated,
depending on the value of \fB$v\fR. This is not true of the normal Tcl parser,
so it is normally recommended to enclose the arguments to \fBexpr\fR in braces.
Without braces, as in
\fBexpr\fR $v ? [a] : [b]
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
.CE
.PP
Set a variable indicating whether an environment variable is defined and has
value of true:
.PP
.CS
set isTrue [\fBexpr\fR {
[info exists ::env(SOME_ENV_VAR)] &&
[string is true -strict $::env(SOME_ENV_VAR)]
}]
.CE
.PP
Generate a random integer in the range 0..99 inclusive:
.PP
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), mathfunc(n), mathop(n), namespace(n), proc(n),
string(n), Tcl(n), while(n)
.SH KEYWORDS
| > > | | > | 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 |
.CE
.PP
Set a variable indicating whether an environment variable is defined and has
value of true:
.PP
.CS
set isTrue [\fBexpr\fR {
# Does the environment variable exist, and...
[info exists ::env(SOME_ENV_VAR)] &&
# ...does it contain a proper true value?
[string is true -strict $::env(SOME_ENV_VAR)]
}]
.CE
.PP
Generate a random integer in the range 0..99 inclusive:
.PP
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), mathfunc(n), mathop(n), namespace(n), proc(n),
string(n), Tcl(n), while(n)
.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison, integer value
.SH COPYRIGHT
.nf
Copyright \(co 1993 The Regents of the University of California.
Copyright \(co 1994-2000 Sun Microsystems Incorporated.
Copyright \(co 2005 Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
.fi
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/fconfigure.n.
| ︙ | ︙ | |||
101 102 103 104 105 106 107 |
system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
.
| | | | | 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 |
system, as returned by \fBencoding system\fR.
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\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. For
output, the end-of-file character is output when the channel is closed.
If \fIchar\fR is the empty string, then there is no special end of file
character marker. For read-write channels, a two-element list specifies
the end of file marker for input and output, respectively. As a
convenience, when setting the end-of-file character for a read-write
channel you can specify a single value that will apply to both reading
and writing. When querying the end-of-file character of a read-write
channel, a two-element list will always be returned. The default value
for \fB\-eofchar\fR is the empty string in all cases except for files
under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1A) for
reading and the empty string for writing.
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.
.TP
\fB\-translation\fR \fImode\fR
.TP
\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR
.
|
| ︙ | ︙ |
Changes to doc/fpclassify.n.
1 | '\" | | | | | 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 8.7 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 8.7\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: .TP |
| ︙ | ︙ |
Changes to doc/http.n.
1 2 | '\" '\" Copyright (c) 1995-1997 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 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-2000 Ajuba Solutions. '\" Copyright (c) 2004 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS \fBpackage require http\fI ?\fB2.9\fR? .\" See Also -useragent option documentation in body! .sp \fB::http::config\fR ?\fI\-option value\fR ...? .sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 | the HTTP operation is done in the background. \fB::http::geturl\fR returns immediately after generating the HTTP request and the callback is invoked when the transaction completes. For this to work, the Tcl event loop must be active. In Tk applications this is always true. For pure-Tcl applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. .SH COMMANDS .TP \fB::http::config\fR ?\fIoptions\fR? . The \fB::http::config\fR command is used to set and query the name of the proxy server and port, and the User-Agent name used in the HTTP requests. If no options are specified, then the current configuration | > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | the HTTP operation is done in the background. \fB::http::geturl\fR returns immediately after generating the HTTP request and the callback is invoked when the transaction completes. For this to work, the Tcl event loop must be active. In Tk applications this is always true. For pure-Tcl applications, the caller can use \fB::http::wait\fR after calling \fB::http::geturl\fR to start the event loop. .PP \fBNote:\fR The event queue is even used without the \fB-command\fR option. As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR is running. .SH COMMANDS .TP \fB::http::config\fR ?\fIoptions\fR? . The \fB::http::config\fR command is used to set and query the name of the proxy server and port, and the User-Agent name used in the HTTP requests. If no options are specified, then the current configuration |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\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) | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\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.9.0 Tcl/8.6.9\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. .TP \fB\-zip\fR \fIboolean\fR . If the value is boolean \fBtrue\fR, then by default requests will send a header |
| ︙ | ︙ | |||
255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
...
set data [read $socket 1000]
set nbytes [string length $data]
...
return $nbytes
}
.CE
.RE
.TP
\fB\-headers\fR \fIkeyvaluelist\fR
.
This option is used to add headers not already specified
by \fB::http::config\fR to the HTTP request. The
\fIkeyvaluelist\fR argument must be a list with an even number of
| > > > > | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
...
set data [read $socket 1000]
set nbytes [string length $data]
...
return $nbytes
}
.CE
.PP
The \fBhttp::geturl\fR code for the \fB-handler\fR option is not compatible with either compression or chunked transfer-encoding. If \fB-handler\fR is specified, then to work around these issues \fBhttp::geturl\fR will reduce the HTTP protocol to 1.0, and override the \fB-zip\fR option (i.e. it will not send the header "\fBAccept-Encoding: gzip,deflate,compress\fR").
.PP
If options \fB-handler\fR and \fB-channel\fR are used together, the handler is responsible for copying the data from the HTTP socket to the specified channel. The name of the channel is available to the handler as element \fB-channel\fR of the token array.
.RE
.TP
\fB\-headers\fR \fIkeyvaluelist\fR
.
This option is used to add headers not already specified
by \fB::http::config\fR to the HTTP request. The
\fIkeyvaluelist\fR argument must be a list with an even number of
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 | Select the HTTP protocol version to use. This should be 1.0 or 1.1 (the default). Should only be necessary for servers that do not understand or otherwise complain about HTTP/1.1. .TP \fB\-query\fR \fIquery\fR . This flag causes \fB::http::geturl\fR to do a POST request that passes the | > > > | | < | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | Select the HTTP protocol version to use. This should be 1.0 or 1.1 (the default). Should only be necessary for servers that do not understand or otherwise complain about HTTP/1.1. .TP \fB\-query\fR \fIquery\fR . This flag causes \fB::http::geturl\fR to do a POST request that passes the \fIquery\fR as payload verbatim to the server. The content format (and encoding) of \fIquery\fR is announced by the header field \fBcontent-type\fR set by the option \fB-type\fR. \fIquery\fR is an x-url-encoding formatted query, if used for html forms. The \fB::http::formatQuery\fR procedure can be used to do the formatting. .TP \fB\-queryblocksize\fR \fIsize\fR . The block size used when posting query data to the URL. At most \fIsize\fR bytes are written at once. After each block, a call to the |
| ︙ | ︙ | |||
543 544 545 546 547 548 549 550 551 552 553 554 555 556 | If the server closes the socket without replying, then no error is raised, but the status of the transaction will be \fBeof\fR. .TP \fBerror\fR . The error message will also be stored in the \fBerror\fR status array element, accessible via \fB::http::error\fR. .PP Another error possibility is that \fB::http::geturl\fR is unable to write all the post query data to the server before the server responds and closes the socket. The error message is saved in the \fBposterror\fR status array element and then \fB::http::geturl\fR attempts to complete the transaction. | > > > > > > > > | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 | If the server closes the socket without replying, then no error is raised, but the status of the transaction will be \fBeof\fR. .TP \fBerror\fR . The error message will also be stored in the \fBerror\fR status array element, accessible via \fB::http::error\fR. .TP \fBtimeout\fR . A timeout occurred before the transaction could complete .TP \fBreset\fR . user-reset .PP Another error possibility is that \fB::http::geturl\fR is unable to write all the post query data to the server before the server responds and closes the socket. The error message is saved in the \fBposterror\fR status array element and then \fB::http::geturl\fR attempts to complete the transaction. |
| ︙ | ︙ | |||
658 659 660 661 662 663 664 | \fBposterror\fR . The error, if any, that occurred while writing the post query data to the server. .TP \fBstatus\fR . | | | < | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 | \fBposterror\fR . The error, if any, that occurred while writing the post query data to the server. .TP \fBstatus\fR . See description in the chapter \fBERRORS\fR above for a list and description of \fBstatus\fR. During the transaction this value is the empty string. .TP \fBtotalsize\fR . A copy of the \fBContent-Length\fR meta-data value. .TP \fBtype\fR . |
| ︙ | ︙ |
Changes to doc/info.n.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | \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. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | \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. .IP \fBproc\fR \fIcommandName\fR was created by \fBproc\fR. .IP \fBinterp\fR \fIcommandName\fR was created by \fBinterp create\fR. .IP \fBzlibStream\fR \fIcommandName\fR was created by \fBzlib stream\fR. .PP Other types may be also registered as well. See \fBTcl_RegisterCommandTypeName\fR. .RE .VE TIP426 |
| ︙ | ︙ | |||
274 275 276 277 278 279 280 | .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? . Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of \fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item is the name of the loaded file and the name of the package for which the file was loaded. For a statically-loaded package the name of the file is the empty | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | .TP \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR? . Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of \fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item is the name of the loaded file and the name of the package 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. .TP \fBinfo locals \fR?\fIpattern\fR? . If \fIpattern\fR is given, returns the name of each local variable matching \fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or \fBvariable\fR is not local. |
| ︙ | ︙ |
Changes to doc/interp.n.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | .SH SYNOPSIS \fBinterp \fIsubcommand \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command makes it possible to create one or more new Tcl interpreters that co-exist with the creating interpreter in the | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
.SH SYNOPSIS
\fBinterp \fIsubcommand \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command makes it possible to create one or more new Tcl
interpreters that co-exist with the creating interpreter in the
same application. The creating interpreter is called the \fIparent\fR
and the new interpreter is called a \fIchild\fR.
A parent can create any number of children, and each child can
itself create additional children for which it is parent, resulting
in a hierarchy of interpreters.
.PP
Each interpreter is independent from the others: it has its own name
space for commands, procedures, and global variables.
A parent interpreter may create connections between its children and
itself using a mechanism called an \fIalias\fR. An \fIalias\fR is
a command in a child interpreter which, when invoked, causes a
command to be invoked in its parent interpreter or in another child
interpreter. The only other connections between interpreters are
through environment variables (the \fBenv\fR variable), which are
normally shared among all interpreters in the application,
and by resource limit exceeded callbacks. Note that the
name space for files (such as the names returned by the \fBopen\fR command)
is no longer shared between interpreters. Explicit commands are provided to
share files and to transfer references to open files from one interpreter
to another.
.PP
The \fBinterp\fR command also provides support for \fIsafe\fR
interpreters. A safe interpreter is a child whose functions have
been greatly restricted, so that it is safe to execute untrusted
scripts without fear of them damaging other interpreters or the
application's environment. For example, all IO channel creation
commands and subprocess creation commands are made inaccessible to safe
interpreters.
See \fBSAFE INTERPRETERS\fR below for more information on
what features are present in a safe interpreter.
The dangerous functionality is not removed from the safe interpreter;
instead, it is \fIhidden\fR, so that only trusted interpreters can obtain
access to it. For a detailed explanation of hidden commands, see
\fBHIDDEN COMMANDS\fR, below.
The alias mechanism can be used for protected communication (analogous to a
kernel call) between a child interpreter and its parent.
See \fBALIAS INVOCATION\fR, below, for more details
on how the alias mechanism works.
.PP
A qualified interpreter name is a proper Tcl list containing a subset of its
ancestors in the interpreter hierarchy, terminated by the string naming the
interpreter in its immediate parent. Interpreter names are relative to the
interpreter in which they are used. For example, if
.QW \fBa\fR
is a child of the current interpreter and it has a child
.QW \fBa1\fR ,
which in turn has a child
.QW \fBa11\fR ,
the qualified name of
.QW \fBa11\fR
in
.QW \fBa\fR
is the list
.QW "\fBa1 a11\fR" .
.PP
The \fBinterp\fR command, described below, accepts qualified interpreter
names as arguments; the interpreter in which the command is being evaluated
can always be referred to as \fB{}\fR (the empty list or string). Note that
it is impossible to refer to a parent (ancestor) interpreter by name in a
child interpreter except through aliases. Also, there is no global name by
which one can refer to the first interpreter created in an application.
Both restrictions are motivated by safety concerns.
.SH "THE INTERP COMMAND"
.PP
The \fBinterp\fR command is used to create, delete, and manipulate
child interpreters, and to share or transfer
channels between interpreters. It can have any of several forms, depending
on the \fIsubcommand\fR argument:
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR
.
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the name of the source command in the
child is different from \fIsrcToken\fR).
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR
.
Deletes the alias for \fIsrcToken\fR in the child interpreter identified by
\fIsrcPath\fR.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR?
.
This command creates an alias between one child and another (see the
\fBalias\fR child command below for creating aliases between a child
and its parent). In this command, either of the child interpreters
may be anywhere in the hierarchy of interpreters under the interpreter
invoking the command.
\fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias.
\fISrcPath\fR is a Tcl list whose elements select a particular
interpreter. For example,
.QW "\fBa b\fR"
identifies an interpreter
.QW \fBb\fR ,
which is a child of interpreter
.QW \fBa\fR ,
which is a child of the invoking interpreter. An empty list specifies
the interpreter invoking the command. \fIsrcCmd\fR gives the name of
a new command, which will be created in the source interpreter.
\fITargetPath\fR and \fItargetCmd\fR specify a target interpreter
and command, and the \fIarg\fR arguments, if any, specify additional
arguments to \fItargetCmd\fR which are prepended to any arguments specified
in the invocation of \fIsrcCmd\fR.
\fITargetCmd\fR may be undefined at the time of this call, or it may
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . | | | | | | | | | | | | | | | 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 | switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the error message string; otherwise, a default error message string will be used. .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? . Creates a child interpreter identified by \fIpath\fR and a new command, called a \fIchild command\fR. The name of the child command is the last component of \fIpath\fR. The new child interpreter and the child command are created in the interpreter identified by the path obtained by removing the last component from \fIpath\fR. For example, if \fIpath\fR is \fBa b c\fR then a new child interpreter and child command named \fBc\fR are created in the interpreter identified by the path \fBa b\fR. The child command may be used to manipulate the new interpreter as described below. If \fIpath\fR is omitted, Tcl creates a unique name of the form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the interpreter and the child command. If the \fB\-safe\fR switch is specified (or if the parent interpreter is a safe interpreter), the new child interpreter will be created as a safe interpreter with limited functionality; otherwise the child will include the full set of Tcl built-in commands and variables. The \fB\-\|\-\fR switch can be used to mark the end of switches; it may be needed if \fIpath\fR is an unusual value such as \fB\-safe\fR. The result of the command is the name of the new interpreter. The name of a child interpreter must be unique among all the children for its parent; an error occurs if a child interpreter by the given name already exists in this parent. The initial recursion limit of the child interpreter is set to the current recursion limit of its parent interpreter. .TP \fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR?? . Controls whether frame-level stack information is captured in the child interpreter identified by \fIpath\fR. If no arguments are given, option and current setting are returned. If \fB\-frame\fR is given, the debug setting is set to the given boolean if provided and the current setting is returned. This only affects the output of \fBinfo frame\fR, in that exact frame-level information for command invocation at the bytecode level is only captured with this setting on. .RS |
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE .TP \fBinterp\fR \fBdelete \fR?\fIpath ...\fR? . Deletes zero or more interpreters given by the optional \fIpath\fR | | | | | | | | | | 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 | attempts are silently ignored. This is needed to maintain the consistency of the underlying interpreter's state. .RE .TP \fBinterp\fR \fBdelete \fR?\fIpath ...\fR? . Deletes zero or more interpreters given by the optional \fIpath\fR arguments, and for each interpreter, it also deletes its children. The command also deletes the child command for each interpreter deleted. For each \fIpath\fR argument, if no interpreter by that name exists, the command raises an error. .TP \fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? . This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as a Tcl script in the child interpreter identified by \fIpath\fR. The result of this evaluation (including all \fBreturn\fR options, such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the \fIpath\fR interpreter; this is so that the implementations (in a parent interpreter) of aliases in a child interpreter can execute scripts in the child that find out information about the child's current state and stack frame. .TP \fBinterp exists \fIpath\fR . Returns \fB1\fR if a child interpreter by the specified \fIpath\fR exists in this parent, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? . Makes the hidden command \fIhiddenName\fR exposed, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), |
| ︙ | ︙ | |||
281 282 283 284 285 286 287 | by \fIpath\fR. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | by \fIpath\fR. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhidden\fR \fIpath\fR . Returns a list of the names of all hidden commands in the interpreter identified by \fIpath\fR. |
| ︙ | ︙ | |||
365 366 367 368 369 370 371 | 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. .TP | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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.
.TP
\fBinterp\fR \fBchildren\fR ?\fIpath\fR?
.
Returns a Tcl list of the names of all the child interpreters associated
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
the invoking interpreter is used.
.TP
\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
.
Synonym for . \fBinterp\fR \fBchildren\fR ?\fIpath\fR?
.TP
\fBinterp\fR \fBtarget\fR \fIpath 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.
.TP
\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR
.
Causes the IO channel identified by \fIchannelId\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
various operations on the interpreter. It has the following
general form:
.PP
.CS
\fIchild command \fR?\fIarg arg ...\fR?
.CE
.PP
\fIChild\fR is the name of the interpreter, and \fIcommand\fR
and the \fIarg\fRs determine the exact behavior of the command.
The valid forms of this command are:
.TP
\fIchild \fBaliases\fR
.
Returns a Tcl list whose elements are the tokens of all the
aliases in \fIchild\fR. The tokens correspond to the values returned when
the aliases were created (which may not be the same
as the current names of the commands).
.TP
\fIchild \fBalias \fIsrcToken\fR
.
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the actual source command in the
child is different from \fIsrcToken\fR).
.TP
\fIchild \fBalias \fIsrcToken \fB{}\fR
.
Deletes the alias for \fIsrcToken\fR in the child interpreter.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fIchild \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
.
Creates an alias such that whenever \fIsrcCmd\fR is invoked
in \fIchild\fR, \fItargetCmd\fR is invoked in the parent.
The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional
arguments, prepended before any arguments passed in the invocation of
\fIsrcCmd\fR.
See \fBALIAS INVOCATION\fR below for details.
The command returns a token that uniquely identifies the command created
\fIsrcCmd\fR, even if the command is renamed afterwards. The token may but
does not have to be equal to \fIsrcCmd\fR.
.TP
\fIchild \fBbgerror\fR ?\fIcmdPrefix\fR?
.
This command either gets or sets the current background exception handler
for the \fIchild\fR interpreter. If \fIcmdPrefix\fR is
absent, the current background exception handler is returned, and if it is
present, it is a list of words (of minimum length one) that describes
what to set the interpreter's background exception handler to. See the
\fBBACKGROUND EXCEPTION HANDLING\fR section for more details.
.TP
\fIchild \fBeval \fIarg \fR?\fIarg ..\fR?
.
This command concatenates all of the \fIarg\fR arguments in
the same fashion as the \fBconcat\fR command, then evaluates
the resulting string as a Tcl script in \fIchild\fR.
The result of this evaluation (including all \fBreturn\fR options,
such as \fB\-errorinfo\fR and \fB\-errorcode\fR information, if an
error occurs) is returned to the invoking interpreter.
Note that the script will be executed in the current context stack frame
of \fIchild\fR; this is so that the implementations (in a parent
interpreter) of aliases in a child interpreter can execute scripts in
the child that find out information about the child's current state
and stack frame.
.TP
\fIchild \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
.
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIchild\fR.
If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIchild \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
.
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
argument is not given, in the \fIchild\fR interpreter.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents children from fooling a parent interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIchild \fBhidden\fR
.
Returns a list of the names of all hidden commands in \fIchild\fR.
.TP
\fIchild \fBinvokehidden\fR ?\fI\-option ...\fR? \fIhiddenName \fR?\fIarg ..\fR?
.
This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIchild\fR. No substitutions or evaluations are
applied to the arguments. Three \fI\-option\fRs are supported, all
of which start with \fB\-\fR: \fB\-namespace\fR (which takes a single
argument afterwards, \fInsName\fR), \fB\-global\fR, and \fB\-\|\-\fR.
If the \fB\-namespace\fR flag is given, the hidden command is invoked in
the specified namespace in the child.
If the \fB\-global\fR flag is given, the command is invoked at the global
level in the child; otherwise it is invoked at the current call frame and
can access local variables in that or outer call frames.
The \fB\-\|\-\fR flag allows the \fIhiddenCmdName\fR argument to start with a
.QW \-
character, and is otherwise unnecessary.
If both the \fB\-namespace\fR and \fB\-global\fR flags are given, the
\fB\-namespace\fR flag is ignored.
Note that the hidden command will be executed (by default) in the
current context stack frame of \fIchild\fR.
For more details on hidden commands,
see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIchild \fBissafe\fR
.
Returns \fB1\fR if the child interpreter is safe, \fB0\fR otherwise.
.TP
\fIchild \fBlimit\fR \fIlimitType\fR ?\fI\-option\fR? ?\fIvalue\fR \fI...\fR?
.
Sets up, manipulates and queries the configuration of the resource
limit \fIlimitType\fR for the child interpreter. If no \fI\-option\fR
is specified, return the current configuration of the limit. If
\fI\-option\fR is the sole argument, return the value of that option.
Otherwise, a list of \fI\-option\fR/\fIvalue\fR argument pairs must
supplied. See \fBRESOURCE LIMITS\fR below for a more detailed explanation of
what limits and options are supported.
.TP
\fIchild \fBmarktrusted\fR
.
Marks the child interpreter as trusted. Can only be invoked by a
trusted interpreter. This command does not expose any hidden
commands in the child interpreter. The command has no effect if the child
is already trusted.
.TP
\fIchild\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
.
Returns the maximum allowable nesting depth for the \fIchild\fR interpreter.
If \fInewlimit\fR is specified, the recursion limit in \fIchild\fR will be
set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
and related procedures in \fIchild\fR will return an error.
The \fInewlimit\fR value is also returned.
The \fInewlimit\fR value must be a positive integer between 1 and the
maximum value of a non-long integer on the platform.
.RS
.PP
The command sets the maximum size of the Tcl call stack only. It cannot
by itself prevent stack overflows on the C stack being used by the
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 | fear of that script damaging the enclosing application or the rest of your computing environment. In order to make an interpreter safe, certain commands and variables are removed from the interpreter. For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating | | | | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 | fear of that script damaging the enclosing application or the rest of your computing environment. In order to make an interpreter safe, certain commands and variables are removed from the interpreter. For example, commands to create files on disk are removed, and the \fBexec\fR command is removed, since it could be used to cause damage through subprocesses. Limited access to these facilities can be provided, by creating aliases to the parent interpreter which check their arguments carefully and provide restricted access to a safe subset of facilities. For example, file creation might be allowed in a particular subdirectory and subprocess invocation might be allowed for a carefully selected and fixed set of programs. .PP A safe interpreter is created by specifying the \fB\-safe\fR switch to the \fBinterp create\fR command. Furthermore, any child created by a safe interpreter will also be safe. .PP A safe interpreter is created with exactly the following set of built-in commands: .DS .ta 1.2i 2.4i 3.6i \fBafter\fR \fBappend\fR \fBapply\fR \fBarray\fR |
| ︙ | ︙ | |||
655 656 657 658 659 660 661 | \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can | | | | | | | | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can be used safely in an untrusted script which is being executed in a safe interpreter even if the target of the alias is not a safe interpreter. The most important thing in guaranteeing safety is to ensure that information passed from the child to the parent is never evaluated or substituted in the parent; if this were to occur, it would enable an evil script in the child to invoke arbitrary functions in the parent, which would compromise security. .PP When the source for an alias is invoked in the child interpreter, the usual Tcl substitutions are performed when parsing that command. These substitutions are carried out in the source interpreter just as they would be for any other command invoked in that interpreter. The command procedure for the source command takes its arguments and merges them with the \fItargetCmd\fR and \fIarg\fRs for the alias to create a new array of arguments. If the words of \fIsrcCmd\fR were |
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | \fItargetCmd\fR and \fIargs\fR were substituted when parsing the command that created the alias, and \fIarg1 - argN\fR are substituted when the alias's source command is parsed in the source interpreter. .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape | | | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 | \fItargetCmd\fR and \fIargs\fR were substituted when parsing the command that created the alias, and \fIarg1 - argN\fR are substituted when the alias's source command is parsed in the source interpreter. .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape mechanism whereby the child interpreter could execute arbitrary code in the parent. This in turn would compromise the security of the system. .SH "HIDDEN COMMANDS" .PP Safe interpreters greatly restrict the functionality available to Tcl programs executing within them. Allowing the untrusted Tcl program to have direct access to this functionality is unsafe, because it can be used for a variety of |
| ︙ | ︙ | |||
718 719 720 721 722 723 724 | unavailable to Tcl scripts executing in the interpreter. However, such hidden commands can be invoked by any trusted ancestor of the safe interpreter, in the context of the safe interpreter, using \fBinterp invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP | | | | | | | | | | | | | | | 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 | unavailable to Tcl scripts executing in the interpreter. However, such hidden commands can be invoked by any trusted ancestor of the safe interpreter, in the context of the safe interpreter, using \fBinterp invoke\fR. Hidden commands and exposed commands reside in separate name spaces. It is possible to define a hidden command and an exposed command by the same name within one interpreter. .PP Hidden commands in a child interpreter can be invoked in the body of procedures called in the parent during alias invocation. For example, an alias for \fBsource\fR could be created in a child interpreter. When it is invoked in the child interpreter, a procedure is called in the parent interpreter to check that the operation is allowable (e.g. it asks to source a file that the child interpreter is allowed to access). The procedure then it invokes the hidden \fBsource\fR command in the child interpreter to actually source in the contents of the file. Note that two commands named \fBsource\fR exist in the child interpreter: the alias, and the hidden command. .PP Because a parent interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. Otherwise, malicious child interpreters could cause a trusted parent interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves or in their descendants. This prevents them from gaining access to hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the set of exposed commands in the interpreter identified by \fIpath\fR, potentially renaming the command in the process. If an exposed command by the targeted name already exists, the operation fails. Similarly, \fBinterp hide\fR moves an exposed command to the set of hidden commands in that interpreter. Safe interpreters are not allowed to move commands between the set of hidden and exposed commands, in either themselves or their descendants. .PP Currently, the names of hidden commands cannot contain namespace qualifiers, and you must first rename a command in a namespace to the global namespace before you can hide it. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This prevents children from fooling a parent interpreter into hiding the wrong command, by making the current namespace be different from the global one. .SH "RESOURCE LIMITS" .PP Every interpreter has two kinds of resource limits that may be imposed by any parent interpreter upon its children. Command limits (of type \fBcommand\fR) restrict the total number of Tcl commands that may be executed by an interpreter (as can be inspected via the \fBinfo cmdcount\fR command), and time limits (of type \fBtime\fR) place a limit by which execution within the interpreter must complete. Note that time limits are expressed as \fIabsolute\fR times (as in \fBclock seconds\fR) and not relative times (as in \fBafter\fR) because they may be modified after creation. .PP When a limit is exceeded for an interpreter, first any handler callbacks defined by parent interpreters are called. If those callbacks increase or remove the limit, execution within the (previously) limited interpreter continues. If the limit is still in force, an error is generated at that point and normal processing of errors within the interpreter (by the \fBcatch\fR command) is disabled, so the error propagates outwards (building a stack-trace as it goes) to the point where the limited interpreter was invoked (e.g. by \fBinterp eval\fR) where it becomes the responsibility of the calling code to catch and handle. |
| ︙ | ︙ | |||
829 830 831 832 833 834 835 | .TP \fB\-value\fR . This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP | | | | | | | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 | .TP \fB\-value\fR . This option specifies the number of commands that the interpreter may execute before triggering the command limit. This option may be the empty string, which indicates that a command limit is not set for the interpreter. .PP Where an interpreter with a resource limit set on it creates a child interpreter, that child interpreter will have resource limits imposed on it that are at least as restrictive as the limits on the creating parent interpreter. If the parent interpreter of the limited parent wishes to relax these conditions, it should hide the \fBinterp\fR command in the child and then use aliases and the \fBinterp invokehidden\fR subcommand to provide such access as it chooses to the \fBinterp\fR command to the limited parent as necessary. .SH "BACKGROUND EXCEPTION HANDLING" .PP When an exception happens in a situation where it cannot be reported directly up the stack (e.g. when processing events in an \fBupdate\fR or \fBvwait\fR call) the exception is instead reported through the background exception handling mechanism. Every interpreter has a background exception handler registered; the default exception |
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
set x 0
while {1} {
puts "Counting up... [incr x]"
}
}
.CE
.SH "SEE ALSO"
| | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 |
set x 0
while {1} {
puts "Counting up... [incr x]"
}
}
.CE
.SH "SEE ALSO"
bgerror(n), load(n), safe(n), Tcl_CreateChild(3), Tcl_Eval(3), Tcl_BackgroundException(3)
.SH KEYWORDS
alias, parent interpreter, safe interpreter, child interpreter
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/library.n.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | \fBauto_mkindex foo *.tcl\fR .CE .PP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | \fBauto_mkindex foo *.tcl\fR .CE .PP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts by sourcing them into a child interpreter and monitoring the proc and namespace commands that are executed. Extensions can use the (undocumented) auto_mkindex_parser package to register other commands that can contribute to the auto_load index. You will have to read through auto.tcl to see how this works. .PP \fBAuto_mkindex_old\fR (which has the same syntax as \fBauto_mkindex\fR) |
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is | | < < < | < < | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a non-word character. The default is "\\W". .TP \fBtcl_wordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a word character. The default is "\\w". .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/lindex.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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. 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 lindex n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/link.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME link \- create link from command to method of object .SH SYNOPSIS .nf | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
link \- create link from command to method of object
.SH SYNOPSIS
.nf
package require tcl::oo
\fBlink\fR \fImethodName\fR ?\fI...\fR?
\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR?
.fi
.BE
.SH DESCRIPTION
The \fBlink\fR command is available within methods. It takes a series of one
|
| ︙ | ︙ |
Changes to doc/load.n.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | be specified. .PP If \fIpackageName\fR is omitted or specified as an empty string, Tcl tries to guess the name of the package. This may be done differently on different platforms. The default guess, which is used on most UNIX platforms, is to take the last element of \fIfileName\fR, strip off the first | | > | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
be specified.
.PP
If \fIpackageName\fR is omitted or specified as an empty string,
Tcl tries to guess the name of the package.
This may be done differently on different platforms.
The default guess, which is used on most UNIX platforms, is to
take the last element of \fIfileName\fR, strip off the first
three characters if they are \fBlib\fR, then strip off the next
three characters if they are \fBtcl\fR, and use any following
alphabetic and underline characters as the module name.
For example, the command \fBload libtclxyz4.2.so\fR uses the module
name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
module name \fBlast\fR.
.PP
If \fIfileName\fR is an empty string, then \fIpackageName\fR must
be specified.
The \fBload\fR command first searches for a statically loaded package
(one that has been registered by calling the \fBTcl_StaticPackage\fR
|
| ︙ | ︙ |
Changes to doc/lpop.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/lrepeat.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2003 Simon Geard. 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 lrepeat n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/lreverse.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2006 Donal K. Fellows. 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 lreverse n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/lsearch.n.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) | | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) If not, the command returns \fB\-1\fR or (if options \fB\-all\fR or \fB\-inline\fR are specified) the empty string. The \fIoption\fR arguments indicates how the elements of the list are to be matched against \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" .PP If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. |
| ︙ | ︙ |
Changes to doc/lset.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. 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 lset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/mathfunc.n.
1 2 3 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. 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 mathfunc n 8.5 Tcl "Tcl Mathematical Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathfunc \- Mathematical functions for Tcl expressions .SH SYNOPSIS package require \fBTcl 8.5-\fR .sp \fB::tcl::mathfunc::abs\fR \fIarg\fR .br \fB::tcl::mathfunc::acos\fR \fIarg\fR .br \fB::tcl::mathfunc::asin\fR \fIarg\fR .br |
| ︙ | ︙ | |||
356 357 358 359 360 361 362 | are returned as an integer value. .SH "SEE ALSO" expr(n), fpclassify(n), mathop(n), namespace(n) .SH "COPYRIGHT" .nf Copyright \(co 1993 The Regents of the University of California. Copyright \(co 1994-2000 Sun Microsystems Incorporated. | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 | are returned as an integer value. .SH "SEE ALSO" expr(n), fpclassify(n), mathop(n), namespace(n) .SH "COPYRIGHT" .nf Copyright \(co 1993 The Regents of the University of California. Copyright \(co 1994-2000 Sun Microsystems Incorporated. Copyright \(co 2005-2006 Kevin B. Kenny <kennykb@acm.org>. .fi '\" Local Variables: '\" mode: nroff '\" fill-column: 78 '\" End: |
Changes to doc/mathop.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | .\" .\" Copyright (c) 2006-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 mathop n 8.5 Tcl "Tcl Mathematical Operator Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathop \- Mathematical operators as Tcl commands .SH SYNOPSIS | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | .\" .\" Copyright (c) 2006-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 mathop n 8.5 Tcl "Tcl Mathematical Operator Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathop \- Mathematical operators as Tcl commands .SH SYNOPSIS package require \fBTcl 8.5-\fR .sp \fB::tcl::mathop::!\fR \fInumber\fR .br \fB::tcl::mathop::~\fR \fInumber\fR .br \fB::tcl::mathop::+\fR ?\fInumber\fR ...? .br |
| ︙ | ︙ |
Changes to doc/memory.n.
1 | '\" | | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans '\" Copyright (c) 2000 Scriptics Corporation. '\" All rights reserved. '\" .TH memory n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME memory \- Control Tcl memory debugging capabilities |
| ︙ | ︙ |
Changes to doc/msgcat.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require tcl 8.7\fR .sp \fBpackage require msgcat 1.7\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp |
| ︙ | ︙ |
Changes to doc/my.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME my, myclass \- invoke any method of current object or its class .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 my, myclass \- invoke any method of current object or its class .SH SYNOPSIS .nf package require tcl::oo \fBmy\fI methodName\fR ?\fIarg ...\fR? \fBmyclass\fI methodName\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/next.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations .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 next, nextto \- invoke superclass method implementations .SH SYNOPSIS .nf package require tcl::oo \fBnext\fR ?\fIarg ...\fR? \fBnextto\fI class\fR ?\fIarg ...\fR? .fi .BE .SH DESCRIPTION |
| ︙ | ︙ |
Changes to doc/object.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::object \- root class of the class hierarchy .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 oo::object \- root class of the class hierarchy .SH SYNOPSIS .nf package require tcl::oo \fBoo::object\fI method \fR?\fIarg ...\fR? .fi .SH "CLASS HIERARCHY" .nf \fBoo::object\fR .fi |
| ︙ | ︙ |
Changes to doc/packagens.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1998-2000 Scriptics Corporation. '\" All rights reserved. '\" .TH pkg::create n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME |
| ︙ | ︙ |
Changes to doc/pkgMkIndex.n.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | script or binary files in \fIdir\fR. The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. .RS .PP \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | script or binary files in \fIdir\fR. The default pattern is \fB*.tcl\fR and \fB*.[info sharedlibextension]\fR. .RS .PP \fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR with package information about all the files given by the \fIpattern\fR arguments. It does this by loading each file into a child interpreter and seeing what packages and new commands appear (this is why it is essential to have \fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls in the files, as described above). If you have a package split among scripts and binary files, or if you have dependencies among files, you may have to use the \fB\-load\fR option |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 | The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading it immediately upon \fBpackage require\fR. This is not compatible with the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the current interpreter and match \fIpkgPat\fR into the child interpreter used to generate the index. The pattern match uses string match rules, but without making case distinctions. See \fBCOMPLEX CASES\fR below. .TP 15 \fB\-verbose\fR Generate output during the indexing process. Output is via the \fBtclLog\fR procedure, which by default prints to stderr. |
| ︙ | ︙ |
Changes to doc/re_syntax.n.
| ︙ | ︙ | |||
289 290 291 292 293 294 295 | and \fB=]\fR is an equivalence class, standing for the sequences of characters of all collating elements equivalent to that one, including itself. (If there are no other equivalent collating elements, the treatment is as if the enclosing delimiters were .QW \fB[.\fR \& and .QW \fB.]\fR .) | | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | and \fB=]\fR is an equivalence class, standing for the sequences of characters of all collating elements equivalent to that one, including itself. (If there are no other equivalent collating elements, the treatment is as if the enclosing delimiters were .QW \fB[.\fR \& and .QW \fB.]\fR .) For example, if \fBo\fR and \fB\(^o\fR are the members of an equivalence class, then .QW \fB[[=o=]]\fR , .QW \fB[[=\(^o=]]\fR , and .QW \fB[o\(^o]\fR \& are all synonymous. An equivalence class may not be an endpoint of a range. .RS .PP (\fINote:\fR Tcl implements only the Unicode locale. It does not define any equivalence classes. The examples above are just illustrations.) .RE .SH ESCAPES |
| ︙ | ︙ |
Changes to doc/safe.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" 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 "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters .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 25 26 27 28 29 30 31 | '\" '\" 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 "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters .SH SYNOPSIS \fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR? .sp \fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR? .sp \fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR? .sp \fB::safe::interpDelete\fR \fIchild\fR .sp \fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? ?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR? ?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR? |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | hosting application. It prevents integrity and privacy attacks. Untrusted Tcl scripts are prevented from corrupting the state of the hosting application or computer. Untrusted scripts are also prevented from disclosing information stored on the hosting computer or in the hosting application to any party. .PP | | | | | | | > > > > > > | | | > > | | | | | | | | | | | 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 |
hosting application.
It prevents integrity and privacy attacks. Untrusted Tcl
scripts are prevented from corrupting the state of the hosting
application or computer. Untrusted scripts are also prevented from
disclosing information stored on the hosting computer or in the
hosting application to any party.
.PP
Safe Tcl allows a parent interpreter to create safe, restricted
interpreters that contain a set of predefined aliases for the \fBsource\fR,
\fBload\fR, \fBfile\fR, \fBencoding\fR, and \fBexit\fR commands and
are able to use the auto-loading and package mechanisms.
.PP
No knowledge of the file system structure is leaked to the
safe interpreter, because it has access only to a virtualized path
containing tokens. When the safe interpreter requests to source a file, it
uses the token in the virtual path as part of the file name to source; the
parent interpreter transparently
translates the token into a real directory name and executes the
requested operation (see the section \fBSECURITY\fR below for details).
Different levels of security can be selected by using the optional flags
of the commands described below.
.PP
All commands provided in the parent interpreter by Safe Tcl reside in
the \fBsafe\fR namespace.
.SH COMMANDS
The following commands are provided in the parent interpreter:
.TP
\fB::safe::interpCreate\fR ?\fIchild\fR? ?\fIoptions...\fR?
Creates a safe interpreter, installs the aliases described in the section
\fBALIASES\fR and initializes the auto-loading and package mechanism as
specified by the supplied \fIoptions\fR.
See the \fBOPTIONS\fR section below for a description of the
optional arguments.
If the \fIchild\fR argument is omitted, a name will be generated.
\fB::safe::interpCreate\fR always returns the interpreter name.
.sp
The interpreter name \fIchild\fR may include namespace separators,
but may not have leading or trailing namespace separators, or excess
colon characters in namespace separators. The interpreter name is
qualified relative to the global namespace ::, not the namespace in which
the \fB::safe::interpCreate\fR command is evaluated.
.TP
\fB::safe::interpInit\fR \fIchild\fR ?\fIoptions...\fR?
This command is similar to \fBinterpCreate\fR except it that does not
create the safe interpreter. \fIchild\fR must have been created by some
other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter
name \fIchild\fR may include namespace separators, subject to the same
restrictions as for \fBinterpCreate\fR.
.TP
\fB::safe::interpConfigure\fR \fIchild\fR ?\fIoptions...\fR?
If no \fIoptions\fR are given, returns the settings for all options for the
named safe interpreter as a list of options and their current values
for that \fIchild\fR.
If a single additional argument is provided,
it will return a list of 2 elements \fIname\fR and \fIvalue\fR where
\fIname\fR is the full name of that option and \fIvalue\fR the current value
for that option and the \fIchild\fR.
If more than two additional arguments are provided, it will reconfigure the
safe interpreter and change each and only the provided options.
See the section on \fBOPTIONS\fR below for options description.
Example of use:
.RS
.PP
.CS
# Create new interp with the same configuration as "$i0":
set i1 [safe::interpCreate {*}[safe::interpConfigure $i0]]
# Get the current deleteHook
set dh [safe::interpConfigure $i0 \-del]
# Change (only) the statics loading ok attribute of an
# interp and its deleteHook (leaving the rest unchanged):
safe::interpConfigure $i0 \-delete {foo bar} \-statics 0
.CE
.RE
.TP
\fB::safe::interpDelete\fR \fIchild\fR
Deletes the safe interpreter and cleans up the corresponding
parent interpreter data structures.
If a \fIdeleteHook\fR script was specified for this interpreter it is
evaluated before the interpreter is deleted, with the name of the
interpreter as an additional argument.
.TP
\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR
This command finds and returns the token for the real directory
\fIdirectory\fR in the safe interpreter's current virtual access path.
It generates an error if the directory is not found.
Example of use:
.RS
.PP
.CS
$child eval [list set tk_library \e
[::safe::interpFindInAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::interpAddToAccessPath\fR \fIchild\fR \fIdirectory\fR
This command adds \fIdirectory\fR to the virtual path maintained for the
safe interpreter in the parent, and returns the token that can be used in
the safe interpreter to obtain access to files in that directory.
If the directory is already in the virtual path, it only returns the token
without adding the directory to the virtual path again.
Example of use:
.RS
.PP
.CS
$child eval [list set tk_library \e
[::safe::interpAddToAccessPath $name $tk_library]]
.CE
.RE
.TP
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
This command installs a script that will be called when interesting
life cycle events occur for a safe interpreter.
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | .PP Below is the output of a sample session in which a safe interpreter attempted to source a file not found in its virtual access path. Note that the safe interpreter only received an error message saying that the file was not found: .PP .CS | | | | | | | 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 |
.PP
Below is the output of a sample session in which a safe interpreter
attempted to source a file not found in its virtual access path.
Note that the safe interpreter only received an error message saying that
the file was not found:
.PP
.CS
NOTICE for child interp10 : Created
NOTICE for child interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
NOTICE for child interp10 : auto_path in interp10 has been set to {$p(:0:)}
ERROR for child interp10 : /foo/bar/init.tcl: no such file or directory
.CE
.RE
.SS OPTIONS
The following options are common to
\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR,
and \fB::safe::interpConfigure\fR.
Any option name can be abbreviated to its minimal
non-ambiguous name.
Option names are not case sensitive.
.TP
\fB\-accessPath\fR \fIdirectoryList\fR
This option sets the list of directories from which the safe interpreter
can \fBsource\fR and \fBload\fR files.
If this option is not specified, or if it is given as the
empty list, the safe interpreter will use the same directories as its
parent for auto-loading.
See the section \fBSECURITY\fR below for more detail about virtual paths,
tokens and access control.
.TP
\fB\-statics\fR \fIboolean\fR
This option specifies if the safe interpreter will be allowed
to load statically linked packages (like \fBload {} Tk\fR).
The default value is \fBtrue\fR :
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 | \fB\-nestedLoadOk\fR This option is a convenience shortcut for \fB\-nested true\fR and thus specifies the safe interpreter will be allowed to load packages into its own sub-interpreters. .TP \fB\-deleteHook\fR \fIscript\fR When this option is given a non-empty \fIscript\fR, it will be | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
\fB\-nestedLoadOk\fR
This option is a convenience shortcut for \fB\-nested true\fR and
thus specifies the safe interpreter will be allowed
to load packages into its own sub-interpreters.
.TP
\fB\-deleteHook\fR \fIscript\fR
When this option is given a non-empty \fIscript\fR, it will be
evaluated in the parent with the name of
the safe interpreter as an additional argument
just before actually deleting the safe interpreter.
Giving an empty value removes any currently installed deletion hook
script for that safe interpreter.
The default value (\fB{}\fR) is not to have any deletion call back.
.SH ALIASES
The following aliases are provided in a safe interpreter:
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 | code and it can request that packages be loaded. .PP Because some of these commands access the local file system, there is a potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, | | | | | 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 | code and it can request that packages be loaded. .PP Because some of these commands access the local file system, there is a potential for information leakage about its directory structure. To prevent this, commands that take file names as arguments in a safe interpreter use tokens instead of the real directory names. These tokens are translated to the real directory name while a request to, e.g., source a file is mediated by the parent interpreter. This virtual path system is maintained in the parent interpreter for each safe interpreter created by \fB::safe::interpCreate\fR or initialized by \fB::safe::interpInit\fR and the path maps tokens accessible in the safe interpreter into real path names on the local file system thus preventing safe interpreters from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments for the \fBsource\fR and \fBload\fR aliases provided to the child are path in the form of \fB[file join \fItoken filename\fB]\fR (i.e. when using the native file path formats: \fItoken\fB/\fIfilename\fR on Unix and \fItoken\fB\e\fIfilename\fR on Windows), where \fItoken\fR is representing one of the directories of the \fIaccessPath\fR list and \fIfilename\fR is one file in that directory (no sub directories access are allowed). |
| ︙ | ︙ | |||
316 317 318 319 320 321 322 | must end up with the extension .PQ \fB.tcl\fR or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in | | | | | | | | | | | | | | | | | | | 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 | must end up with the extension .PQ \fB.tcl\fR or be called .PQ \fBtclIndex\fR . .PP Each element of the initial access path list will be assigned a token that will be set in the child \fBauto_path\fR and the first element of that list will be set as the \fBtcl_library\fR for that child. .PP If the access path argument is not given or is the empty list, the default behavior is to let the child access the same packages as the parent has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous as they run in the child interpreter) and C extensions that provides a _SafeInit entry point). For that purpose, the parent's \fBauto_path\fR will be used to construct the child access path. In order that the child successfully loads the Tcl library files (which includes the auto-loading mechanism itself) the \fBtcl_library\fR will be added or moved to the first position if necessary, in the child access path, so the child \fBtcl_library\fR will be the same as the parent's (its real path will still be invisible to the child though). In order that auto-loading works the same for the child and the parent in this by default case, the first-level sub directories of each directory in the parent \fBauto_path\fR will also be added (if not already included) to the child access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag instead of relying on this default mechanism. .PP When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS alias, auto\-loading, auto_mkindex, load, parent interpreter, safe interpreter, child interpreter, source '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/self.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME self \- method call internal introspection .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 self \- method call internal introspection .SH SYNOPSIS .nf package require tcl::oo \fBself\fR ?\fIsubcommand\fR? .fi .BE .SH DESCRIPTION The \fBself\fR command, which should only be used from within the context of a call to a method (i.e. inside a method, constructor or destructor body) is |
| ︙ | ︙ |
Changes to doc/singleton.n.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::singleton \- a class that does only allows one instance of itself .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 oo::singleton \- a class that does only allows one instance of itself .SH SYNOPSIS .nf package require tcl::oo \fBoo::singleton\fI method \fR?\fIarg ...\fR? .fi .SH "CLASS HIERARCHY" .nf \fBoo::object\fR \(-> \fBoo::class\fR |
| ︙ | ︙ |
Changes to doc/socket.n.
1 2 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" Copyright (c) 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. '\" .TH socket n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS |
| ︙ | ︙ |
Changes to doc/source.n.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2). .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2). .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option is omitted, the utf-8 encoding is assumed. .SH EXAMPLE .PP Run the script in the file \fBfoo.tcl\fR and then the script in the file \fBbar.tcl\fR: .PP .CS \fBsource\fR foo.tcl |
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
| | | 501 502 503 504 505 506 507 508 509 510 511 512 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, integer value, match, pattern, string, word, equal,
ctype, character, reverse
.\" Local Variables:
.\" mode: nroff
.\" End:
|
Changes to doc/tclsh.1.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | the medium, or by the character, .QW \e032 .PQ \eu001a ", control-Z" . If this character is present in the file, the \fBtclsh\fR application will read text up to but not including the character. An application that requires this character in the file may safely encode it as .QW \e032 , | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | the medium, or by the character, .QW \e032 .PQ \eu001a ", control-Z" . If this character is present in the file, the \fBtclsh\fR application will read text up to but not including the character. An application that requires this character in the file may safely encode it as .QW \e032 , .QW \ex1A , or .QW \eu001a ; or may generate it by use of commands such as \fBformat\fR or \fBbinary\fR. There is no automatic evaluation of \fB.tclshrc\fR when the name of a script file is presented on the \fBtclsh\fR command line, but the script file can always \fBsource\fR it if desired. .PP |
| ︙ | ︙ |
Changes to doc/tcltest.n.
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | to \fBoutputChannel\fR. This command also restores the original shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR . | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | to \fBoutputChannel\fR. This command also restores the original shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR . This is a main command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. .SS "CONFIGURATION COMMANDS" .TP \fBconfigure\fR |
| ︙ | ︙ | |||
800 801 802 803 804 805 806 | and sorted. Then each file will be evaluated in turn. If \fBconfigure \-singleproc\fR is true, then each file will be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child | | | | | | | 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 | and sorted. Then each file will be evaluated in turn. If \fBconfigure \-singleproc\fR is true, then each file will be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful when testing can cause errors so severe that a process terminates. Although such an error may terminate a child process evaluating one file, the main process can continue with the rest of the test suite. In multi-process operation, the configuration of \fBtcltest\fR in the main process is passed to the child processes as command line arguments, with the exception of \fBconfigure \-outfile\fR. The \fBrunAllTests\fR command in the main process collects all output from the child processes and collates their results into one main report. Any reports of individual test failures, or messages requested by a \fBconfigure \-verbose\fR setting are passed directly on to \fBoutputChannel\fR by the main process. .PP After evaluating all selected test files, a summary of the results is printed to \fBoutputChannel\fR. The summary includes the total number of \fBtest\fRs evaluated, broken down into those skipped, those passed, and those failed. The summary also notes the number of files evaluated, and the names of any files with failing tests or errors. A list of |
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 | all files to be evaluated in a common interpreter. A simple way to achieve this is to have your tests define all their commands and variables in a namespace that is deleted when the test file evaluation is complete. A good namespace to use is a child namespace \fBtest\fR of the namespace of the module you are testing. .PP A test file should also be able to be evaluated directly as a script, | | | | 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 |
all files to be evaluated in a common interpreter. A simple way to
achieve this is to have your tests define all their commands and variables
in a namespace that is deleted when the test file evaluation is complete.
A good namespace to use is a child namespace \fBtest\fR of the namespace
of the module you are testing.
.PP
A test file should also be able to be evaluated directly as a script,
not depending on being called by a main \fBrunAllTests\fR. This
means that each test file should process command line arguments to give
the tester all the configuration control that \fBtcltest\fR provides.
.PP
After all \fBtest\fRs in a test file, the command \fBcleanupTests\fR
should be called.
.IP [7]
Here is a sketch of a sample test file illustrating those points:
.RS
.PP
.CS
package require tcltest 2.5
eval \fB::tcltest::configure\fR $argv
package require example
namespace eval ::example::test {
namespace import ::tcltest::*
\fBtestConstraint\fR X [expr {...}]
variable SETUP {#common setup code}
variable CLEANUP {#common cleanup code}
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | The next level of organization is a full test suite, made up of several test files. One script is used to control the entire suite. The basic function of this script is to call \fBrunAllTests\fR after doing any necessary setup. This script is usually named \fBall.tcl\fR because that is the default name used by \fBrunAllTests\fR when combining multiple test suites into one testing run. .IP [8] | | < | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
The next level of organization is a full test suite, made up of several
test files. One script is used to control the entire suite. The
basic function of this script is to call \fBrunAllTests\fR after
doing any necessary setup. This script is usually named \fBall.tcl\fR
because that is the default name used by \fBrunAllTests\fR when combining
multiple test suites into one testing run.
.IP [8]
Here is a sketch of a sample test suite main script:
.RS
.PP
.CS
package require tcltest 2.5
package require example
\fB::tcltest::configure\fR -testdir \e
[file dirname [file normalize [info script]]]
eval \fB::tcltest::configure\fR $argv
\fB::tcltest::runAllTests\fR
.CE
.RE
|
| ︙ | ︙ |
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 | .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 \fBpackage require tcl::zipfs \fR?\fB1.0\fR? .sp \fBzipfs canonical\fR ?\fImntpnt\fR? \fIfilename\fR ?\fIZIPFS\fR? \fBzipfs exists\fR \fIfilename\fR \fBzipfs find\fR \fIdirectoryName\fR \fBzipfs info\fR \fIfilename\fR \fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR? \fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR? |
| ︙ | ︙ |
Changes to doc/zlib.n.
| ︙ | ︙ | |||
189 190 191 192 193 194 195 | \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . | | > > > | > > > > | > | | 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 | \fB\-level\fI compressionLevel\fR . How hard to compress the data. Must be an integer from 0 (uncompressed) to 9 (maximally compressed). .TP \fB\-limit\fI readaheadLimit\fR . The maximum number of bytes ahead to read when decompressing. .RS .PP This option has become \fBirrelevant\fR. It was originally introduced to prevent Tcl from reading beyond the end of a compressed stream in multi-stream channels to ensure that the data after was left alone for further reading, at the cost of speed. .PP Tcl now automatically returns any bytes it has read beyond the end of a compressed stream back to the channel, making them appear as unread to further readers. .RE .PP Both compressing and decompressing channel transformations add extra configuration options that may be accessed through \fBchan configure\fR. The options are: .TP \fB\-checksum\fI checksum\fR . |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the | | < | < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 | This read-only option, only valid for decompressing transforms that are processing gzip-format data, returns the dictionary describing the header read off the data stream. .TP \fB\-limit\fI readaheadLimit\fR . This read-write option is used by decompressing channels to control the maximum number of bytes ahead to read from the underlying data source. See above for more information. .RE .SS "STREAMING SUBCOMMAND" .TP \fBzlib stream\fI mode\fR ?\fIoptions\fR? . Creates a streaming compression or decompression command based on the \fImode\fR, and return the name of the command. For a description of how that |
| ︙ | ︙ |
Changes to generic/regc_color.c.
1 2 3 4 | /* * colorings of characters * This file is #included by regcomp.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * colorings of characters * This file is #included by regcomp.c. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regc_cvec.c.
1 2 3 4 | /* * Utility functions for handling cvecs * This file is #included by regcomp.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * Utility functions for handling cvecs * This file is #included by regcomp.c. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regc_lex.c.
1 2 3 4 | /* * lexical analyzer * This file is #included by regcomp.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * lexical analyzer * This file is #included by regcomp.c. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']')
};
#define PUNCT_CONN \
CHR('_'), \
| | | | | | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']')
};
#define PUNCT_CONN \
CHR('_'), \
0x203F /* UNDERTIE */, \
0x2040 /* CHARACTER TIE */,\
0x2054 /* INVERTED UNDERTIE */,\
0xFE33 /* PRESENTATION FORM FOR VERTICAL LOW LINE */, \
0xFE34 /* PRESENTATION FORM FOR VERTICAL WAVY LOW LINE */, \
0xFE4D /* DASHED LOW LINE */, \
0xFE4E /* CENTRELINE LOW LINE */, \
0xFE4F /* WAVY LOW LINE */, \
0xFF3F /* FULLWIDTH LOW LINE */
static const chr backw[] = { /* \w */
CHR('['), CHR('['), CHR(':'),
CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
CHR(':'), CHR(']'), PUNCT_CONN, CHR(']')
};
static const chr backW[] = { /* \W */
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
case CHR('0'):
NOTE(REG_UUNPORT);
v->now--; /* put first digit back */
c = (uchr) lexdigits(v, 8, 1, 3);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
| | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
case CHR('0'):
NOTE(REG_UUNPORT);
v->now--; /* put first digit back */
c = (uchr) lexdigits(v, 8, 1, 3);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
if (c > 0xFF) {
/* out of range, so we handled one digit too much */
v->now--;
c >>= 3;
}
RETV(PLAIN, c);
break;
default:
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
int len;
chr c;
int d;
const uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
| | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 |
int len;
chr c;
int d;
const uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
if (n > 0x10FFF) {
/* Stop when continuing would otherwise overflow */
break;
}
c = *v->now++;
switch (c) {
case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
|
| ︙ | ︙ |
Changes to generic/regc_locale.c.
1 2 3 4 5 6 | /* * regc_locale.c -- * * This file contains the Unicode locale specific regexp routines. * This file is #included by regcomp.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * regc_locale.c -- * * This file contains the Unicode locale specific regexp routines. * This file is #included by regcomp.c. * * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* ASCII character-name table */ |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
*/
/*
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | < | | | | | | | | | > > | | | | | | | < | | > | | < | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | | 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 |
*/
/*
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
{0x41, 0x5A}, {0x61, 0x7A}, {0xC0, 0xD6}, {0xD8, 0xF6},
{0xF8, 0x2C1}, {0x2C6, 0x2D1}, {0x2E0, 0x2E4}, {0x370, 0x374},
{0x37A, 0x37D}, {0x388, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x3F5},
{0x3F7, 0x481}, {0x48A, 0x52F}, {0x531, 0x556}, {0x560, 0x588},
{0x5D0, 0x5EA}, {0x5EF, 0x5F2}, {0x620, 0x64A}, {0x671, 0x6D3},
{0x6FA, 0x6FC}, {0x712, 0x72F}, {0x74D, 0x7A5}, {0x7CA, 0x7EA},
{0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86A}, {0x8A0, 0x8B4},
{0x8B6, 0x8C7}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980},
{0x985, 0x98C}, {0x993, 0x9A8}, {0x9AA, 0x9B0}, {0x9B6, 0x9B9},
{0x9DF, 0x9E1}, {0xA05, 0xA0A}, {0xA13, 0xA28}, {0xA2A, 0xA30},
{0xA59, 0xA5C}, {0xA72, 0xA74}, {0xA85, 0xA8D}, {0xA8F, 0xA91},
{0xA93, 0xAA8}, {0xAAA, 0xAB0}, {0xAB5, 0xAB9}, {0xB05, 0xB0C},
{0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39}, {0xB5F, 0xB61},
{0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, {0xBA8, 0xBAA},
{0xBAE, 0xBB9}, {0xC05, 0xC0C}, {0xC0E, 0xC10}, {0xC12, 0xC28},
{0xC2A, 0xC39}, {0xC58, 0xC5A}, {0xC85, 0xC8C}, {0xC8E, 0xC90},
{0xC92, 0xCA8}, {0xCAA, 0xCB3}, {0xCB5, 0xCB9}, {0xD04, 0xD0C},
{0xD0E, 0xD10}, {0xD12, 0xD3A}, {0xD54, 0xD56}, {0xD5F, 0xD61},
{0xD7A, 0xD7F}, {0xD85, 0xD96}, {0xD9A, 0xDB1}, {0xDB3, 0xDBB},
{0xDC0, 0xDC6}, {0xE01, 0xE30}, {0xE40, 0xE46}, {0xE86, 0xE8A},
{0xE8C, 0xEA3}, {0xEA7, 0xEB0}, {0xEC0, 0xEC4}, {0xEDC, 0xEDF},
{0xF40, 0xF47}, {0xF49, 0xF6C}, {0xF88, 0xF8C}, {0x1000, 0x102A},
{0x1050, 0x1055}, {0x105A, 0x105D}, {0x106E, 0x1070}, {0x1075, 0x1081},
{0x10A0, 0x10C5}, {0x10D0, 0x10FA}, {0x10FC, 0x1248}, {0x124A, 0x124D},
{0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D},
{0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5},
{0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A},
{0x1380, 0x138F}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD}, {0x1401, 0x166C},
{0x166F, 0x167F}, {0x1681, 0x169A}, {0x16A0, 0x16EA}, {0x16F1, 0x16F8},
{0x1700, 0x170C}, {0x170E, 0x1711}, {0x1720, 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, 0x1B4B},
{0x1B83, 0x1BA0}, {0x1BBA, 0x1BE5}, {0x1C00, 0x1C23}, {0x1C4D, 0x1C4F},
{0x1C5A, 0x1C7D}, {0x1C80, 0x1C88}, {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, 0x2C2E}, {0x2C30, 0x2C5E}, {0x2C60, 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, 0x9FFC}, {0xA000, 0xA48C},
{0xA4D0, 0xA4FD}, {0xA500, 0xA60C}, {0xA610, 0xA61F}, {0xA640, 0xA66E},
{0xA67F, 0xA69D}, {0xA6A0, 0xA6E5}, {0xA717, 0xA71F}, {0xA722, 0xA788},
{0xA78B, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 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}, {0xAB5C, 0xAB69},
{0xAB70, 0xABE2}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB},
{0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17},
{0xFB1F, 0xFB28}, {0xFB2A, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBB1},
{0xFBD3, 0xFD3D}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFB},
{0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF21, 0xFF3A}, {0xFF41, 0xFF5A},
{0xFF66, 0xFFBE}, {0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7},
{0xFFDA, 0xFFDC}
#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},
{0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {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}, {0x10E80, 0x10EA9},
{0x10F00, 0x10F1C}, {0x10F30, 0x10F45}, {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}, {0x11400, 0x11434},
{0x11447, 0x1144A}, {0x1145F, 0x11461}, {0x11480, 0x114AF}, {0x11580, 0x115AE},
{0x115D8, 0x115DB}, {0x11600, 0x1162F}, {0x11680, 0x116AA}, {0x11700, 0x1171A},
{0x11800, 0x1182B}, {0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913},
{0x11918, 0x1192F}, {0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32},
{0x11A5C, 0x11A89}, {0x11AC0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E},
{0x11C72, 0x11C8F}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65},
{0x11D6A, 0x11D89}, {0x11EE0, 0x11EF2}, {0x12000, 0x12399}, {0x12480, 0x12543},
{0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43}, {0x16B63, 0x16B77},
{0x16B7D, 0x16B8F}, {0x16E40, 0x16E7F}, {0x16F00, 0x16F4A}, {0x16F93, 0x16F9F},
{0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1B000, 0x1B11E},
{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},
{0x1E100, 0x1E12C}, {0x1E137, 0x1E13D}, {0x1E2C0, 0x1E2EB}, {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, 0x2A6DD},
{0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0},
{0x2F800, 0x2FA1D}, {0x30000, 0x3134A}
#endif
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static const chr alphaCharTable[] = {
0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386,
0x38C, 0x559, 0x66E, 0x66F, 0x6D5, 0x6E5, 0x6E6, 0x6EE, 0x6EF,
0x6FF, 0x710, 0x7B1, 0x7F4, 0x7F5, 0x7FA, 0x81A, 0x824, 0x828,
0x93D, 0x950, 0x98F, 0x990, 0x9B2, 0x9BD, 0x9CE, 0x9DC, 0x9DD,
0x9F0, 0x9F1, 0x9FC, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36,
0xA38, 0xA39, 0xA5E, 0xAB2, 0xAB3, 0xABD, 0xAD0, 0xAE0, 0xAE1,
0xAF9, 0xB0F, 0xB10, 0xB32, 0xB33, 0xB3D, 0xB5C, 0xB5D, 0xB71,
0xB83, 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0,
0xC3D, 0xC60, 0xC61, 0xC80, 0xCBD, 0xCDE, 0xCE0, 0xCE1, 0xCF1,
0xCF2, 0xD3D, 0xD4E, 0xDBD, 0xE32, 0xE33, 0xE81, 0xE82, 0xE84,
0xEA5, 0xEB2, 0xEB3, 0xEBD, 0xEC6, 0xF00, 0x103F, 0x1061, 0x1065,
0x1066, 0x108E, 0x10C7, 0x10CD, 0x1258, 0x12C0, 0x17D7, 0x17DC, 0x18AA,
0x1AA7, 0x1BAE, 0x1BAF, 0x1CF5, 0x1CF6, 0x1CFA, 0x1F59, 0x1F5B, 0x1F5D,
0x1FBE, 0x2071, 0x207F, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128,
0x214E, 0x2183, 0x2184, 0x2CF2, 0x2CF3, 0x2D27, 0x2D2D, 0x2D6F, 0x2E2F,
0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA8FB, 0xA8FD, 0xA8FE,
0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5, 0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E,
0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x109BE,
0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27, 0x11144, 0x11147, 0x11176, 0x111DA,
0x111DC, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x114C4,
0x114C5, 0x114C7, 0x11644, 0x116B8, 0x11909, 0x11915, 0x11916, 0x1193F, 0x11941,
0x119E1, 0x119E3, 0x11A00, 0x11A3A, 0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09,
0x11D46, 0x11D67, 0x11D68, 0x11D98, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3,
0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 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 (sizeof(alphaCharTable)/sizeof(chr))
/*
* Unicode: control characters.
*/
static const crange controlRangeTable[] = {
{0x0, 0x1F}, {0x7F, 0x9F}, {0x600, 0x605}, {0x200B, 0x200F},
{0x202A, 0x202E}, {0x2060, 0x2064}, {0x2066, 0x206F}, {0xE000, 0xF8FF},
{0xFFF9, 0xFFFB}
#if CHRBITS > 16
,{0x13430, 0x13438}, {0x1BCA0, 0x1BCA3}, {0x1D173, 0x1D17A}, {0xE0020, 0xE007F},
{0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD}
#endif
};
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static const chr controlCharTable[] = {
0xAD, 0x61C, 0x6DD, 0x70F, 0x8E2, 0x180E, 0xFEFF
#if CHRBITS > 16
,0x110BD, 0x110CD, 0xE0001
#endif
};
#define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr))
/*
* Unicode: decimal digit characters.
*/
static const crange digitRangeTable[] = {
{0x30, 0x39}, {0x660, 0x669}, {0x6F0, 0x6F9}, {0x7C0, 0x7C9},
{0x966, 0x96F}, {0x9E6, 0x9EF}, {0xA66, 0xA6F}, {0xAE6, 0xAEF},
{0xB66, 0xB6F}, {0xBE6, 0xBEF}, {0xC66, 0xC6F}, {0xCE6, 0xCEF},
{0xD66, 0xD6F}, {0xDE6, 0xDEF}, {0xE50, 0xE59}, {0xED0, 0xED9},
{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}, {0x11066, 0x1106F}, {0x110F0, 0x110F9},
{0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9}, {0x11450, 0x11459},
{0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9}, {0x11730, 0x11739},
{0x118E0, 0x118E9}, {0x11950, 0x11959}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59},
{0x11DA0, 0x11DA9}, {0x16A60, 0x16A69}, {0x16B50, 0x16B59}, {0x1D7CE, 0x1D7FF},
{0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9}, {0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9}
#endif
};
#define NUM_DIGIT_RANGE (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}, {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}, {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},
{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}, {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}, {0x11C41, 0x11C45}, {0x12470, 0x12474}, {0x16B37, 0x16B3B},
{0x16E97, 0x16E9A}, {0x1DA87, 0x1DA8B}
#endif
};
#define NUM_PUNCT_RANGE (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, 0x61E, 0x61F, 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, 0x1C7E, 0x1C7F, 0x1CD3,
0x207D, 0x207E, 0x208D, 0x208E, 0x2329, 0x232A, 0x27C5, 0x27C6, 0x29FC,
0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x2E52, 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, 0x10EAD, 0x110BB,
0x110BC, 0x11174, 0x11175, 0x111CD, 0x111DB, 0x112A9, 0x1145A, 0x1145B, 0x1145D,
0x114C6, 0x1183B, 0x119E2, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, 0x16A6E,
0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, 0x1E95F
#endif
};
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
*/
static const crange spaceRangeTable[] = {
{0x9, 0xD}, {0x2000, 0x200B}
};
#define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange))
static const chr spaceCharTable[] = {
0x20, 0x85, 0xA0, 0x1680, 0x180E, 0x2028, 0x2029, 0x202F, 0x205F,
0x2060, 0x3000, 0xFEFF
};
#define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr))
/*
* Unicode: lowercase characters.
*/
static const crange lowerRangeTable[] = {
{0x61, 0x7A}, {0xDF, 0xF6}, {0xF8, 0xFF}, {0x17E, 0x180},
{0x199, 0x19B}, {0x1BD, 0x1BF}, {0x233, 0x239}, {0x24F, 0x293},
{0x295, 0x2AF}, {0x37B, 0x37D}, {0x3AC, 0x3CE}, {0x3D5, 0x3D7},
{0x3EF, 0x3F3}, {0x430, 0x45F}, {0x560, 0x588}, {0x10D0, 0x10FA},
{0x10FD, 0x10FF}, {0x13F8, 0x13FD}, {0x1C80, 0x1C88}, {0x1D00, 0x1D2B},
{0x1D6B, 0x1D77}, {0x1D79, 0x1D9A}, {0x1E95, 0x1E9D}, {0x1EFF, 0x1F07},
{0x1F10, 0x1F15}, {0x1F20, 0x1F27}, {0x1F30, 0x1F37}, {0x1F40, 0x1F45},
{0x1F50, 0x1F57}, {0x1F60, 0x1F67}, {0x1F70, 0x1F7D}, {0x1F80, 0x1F87},
{0x1F90, 0x1F97}, {0x1FA0, 0x1FA7}, {0x1FB0, 0x1FB4}, {0x1FC2, 0x1FC4},
{0x1FD0, 0x1FD3}, {0x1FE0, 0x1FE7}, {0x1FF2, 0x1FF4}, {0x2146, 0x2149},
{0x2C30, 0x2C5E}, {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}, {0x10CC0, 0x10CF2}, {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}, {0x1E922, 0x1E943}
#endif
};
#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
static const chr lowerCharTable[] = {
0xB5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10B, 0x10D, 0x10F,
0x111, 0x113, 0x115, 0x117, 0x119, 0x11B, 0x11D, 0x11F, 0x121,
0x123, 0x125, 0x127, 0x129, 0x12B, 0x12D, 0x12F, 0x131, 0x133,
0x135, 0x137, 0x138, 0x13A, 0x13C, 0x13E, 0x140, 0x142, 0x144,
0x146, 0x148, 0x149, 0x14B, 0x14D, 0x14F, 0x151, 0x153, 0x155,
0x157, 0x159, 0x15B, 0x15D, 0x15F, 0x161, 0x163, 0x165, 0x167,
0x169, 0x16B, 0x16D, 0x16F, 0x171, 0x173, 0x175, 0x177, 0x17A,
0x17C, 0x183, 0x185, 0x188, 0x18C, 0x18D, 0x192, 0x195, 0x19E,
0x1A1, 0x1A3, 0x1A5, 0x1A8, 0x1AA, 0x1AB, 0x1AD, 0x1B0, 0x1B4,
0x1B6, 0x1B9, 0x1BA, 0x1C6, 0x1C9, 0x1CC, 0x1CE, 0x1D0, 0x1D2,
0x1D4, 0x1D6, 0x1D8, 0x1DA, 0x1DC, 0x1DD, 0x1DF, 0x1E1, 0x1E3,
0x1E5, 0x1E7, 0x1E9, 0x1EB, 0x1ED, 0x1EF, 0x1F0, 0x1F3, 0x1F5,
0x1F9, 0x1FB, 0x1FD, 0x1FF, 0x201, 0x203, 0x205, 0x207, 0x209,
0x20B, 0x20D, 0x20F, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21B,
0x21D, 0x21F, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22B, 0x22D,
0x22F, 0x231, 0x23C, 0x23F, 0x240, 0x242, 0x247, 0x249, 0x24B,
0x24D, 0x371, 0x373, 0x377, 0x390, 0x3D0, 0x3D1, 0x3D9, 0x3DB,
0x3DD, 0x3DF, 0x3E1, 0x3E3, 0x3E5, 0x3E7, 0x3E9, 0x3EB, 0x3ED,
0x3F5, 0x3F8, 0x3FB, 0x3FC, 0x461, 0x463, 0x465, 0x467, 0x469,
0x46B, 0x46D, 0x46F, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47B,
0x47D, 0x47F, 0x481, 0x48B, 0x48D, 0x48F, 0x491, 0x493, 0x495,
0x497, 0x499, 0x49B, 0x49D, 0x49F, 0x4A1, 0x4A3, 0x4A5, 0x4A7,
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, 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, 0xA7C3, 0xA7C8,
0xA7CA, 0xA7F6, 0xA7FA
#if CHRBITS > 16
,0x1D4BB, 0x1D7CB
#endif
};
#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
/*
* Unicode: uppercase characters.
*/
static const crange upperRangeTable[] = {
{0x41, 0x5A}, {0xC0, 0xD6}, {0xD8, 0xDE}, {0x189, 0x18B},
{0x18E, 0x191}, {0x196, 0x198}, {0x1B1, 0x1B3}, {0x1F6, 0x1F8},
{0x243, 0x246}, {0x388, 0x38A}, {0x391, 0x3A1}, {0x3A3, 0x3AB},
{0x3D2, 0x3D4}, {0x3FD, 0x42F}, {0x531, 0x556}, {0x10A0, 0x10C5},
{0x13A0, 0x13F5}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF}, {0x1F08, 0x1F0F},
{0x1F18, 0x1F1D}, {0x1F28, 0x1F2F}, {0x1F38, 0x1F3F}, {0x1F48, 0x1F4D},
{0x1F68, 0x1F6F}, {0x1FB8, 0x1FBB}, {0x1FC8, 0x1FCB}, {0x1FD8, 0x1FDB},
{0x1FE8, 0x1FEC}, {0x1FF8, 0x1FFB}, {0x210B, 0x210D}, {0x2110, 0x2112},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2E},
{0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE},
{0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A}
#if CHRBITS > 16
,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10C80, 0x10CB2}, {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 (sizeof(upperRangeTable)/sizeof(crange))
static const chr upperCharTable[] = {
0x100, 0x102, 0x104, 0x106, 0x108, 0x10A, 0x10C, 0x10E, 0x110,
0x112, 0x114, 0x116, 0x118, 0x11A, 0x11C, 0x11E, 0x120, 0x122,
0x124, 0x126, 0x128, 0x12A, 0x12C, 0x12E, 0x130, 0x132, 0x134,
0x136, 0x139, 0x13B, 0x13D, 0x13F, 0x141, 0x143, 0x145, 0x147,
0x14A, 0x14C, 0x14E, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15A,
0x15C, 0x15E, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16A, 0x16C,
0x16E, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17B, 0x17D,
0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19C, 0x19D,
0x19F, 0x1A0, 0x1A2, 0x1A4, 0x1A6, 0x1A7, 0x1A9, 0x1AC, 0x1AE,
0x1AF, 0x1B5, 0x1B7, 0x1B8, 0x1BC, 0x1C4, 0x1C7, 0x1CA, 0x1CD,
0x1CF, 0x1D1, 0x1D3, 0x1D5, 0x1D7, 0x1D9, 0x1DB, 0x1DE, 0x1E0,
0x1E2, 0x1E4, 0x1E6, 0x1E8, 0x1EA, 0x1EC, 0x1EE, 0x1F1, 0x1F4,
0x1FA, 0x1FC, 0x1FE, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20A,
0x20C, 0x20E, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21A, 0x21C,
0x21E, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22A, 0x22C, 0x22E,
0x230, 0x232, 0x23A, 0x23B, 0x23D, 0x23E, 0x241, 0x248, 0x24A,
0x24C, 0x24E, 0x370, 0x372, 0x376, 0x37F, 0x386, 0x38C, 0x38E,
0x38F, 0x3CF, 0x3D8, 0x3DA, 0x3DC, 0x3DE, 0x3E0, 0x3E2, 0x3E4,
0x3E6, 0x3E8, 0x3EA, 0x3EC, 0x3EE, 0x3F4, 0x3F7, 0x3F9, 0x3FA,
0x460, 0x462, 0x464, 0x466, 0x468, 0x46A, 0x46C, 0x46E, 0x470,
0x472, 0x474, 0x476, 0x478, 0x47A, 0x47C, 0x47E, 0x480, 0x48A,
0x48C, 0x48E, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49A, 0x49C,
0x49E, 0x4A0, 0x4A2, 0x4A4, 0x4A6, 0x4A8, 0x4AA, 0x4AC, 0x4AE,
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, 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, 0xA7C2, 0xA7C9, 0xA7F5
#if CHRBITS > 16
,0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504, 0x1D505, 0x1D538,
0x1D539, 0x1D546, 0x1D7CA
#endif
};
#define NUM_UPPER_CHAR (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}, {0x61E, 0x6DC}, {0x6DE, 0x70D},
{0x710, 0x74A}, {0x74D, 0x7B1}, {0x7C0, 0x7FA}, {0x7FD, 0x82D},
{0x830, 0x83E}, {0x840, 0x85B}, {0x860, 0x86A}, {0x8A0, 0x8B4},
{0x8B6, 0x8C7}, {0x8D3, 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}, {0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39},
{0xB3C, 0xB44}, {0xB4B, 0xB4D}, {0xB55, 0xB57}, {0xB5F, 0xB63},
{0xB66, 0xB77}, {0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95},
{0xBA8, 0xBAA}, {0xBAE, 0xBB9}, {0xBBE, 0xBC2}, {0xBC6, 0xBC8},
{0xBCA, 0xBCD}, {0xBE6, 0xBFA}, {0xC00, 0xC0C}, {0xC0E, 0xC10},
{0xC12, 0xC28}, {0xC2A, 0xC39}, {0xC3D, 0xC44}, {0xC46, 0xC48},
{0xC4A, 0xC4D}, {0xC58, 0xC5A}, {0xC60, 0xC63}, {0xC66, 0xC6F},
{0xC77, 0xC8C}, {0xC8E, 0xC90}, {0xC92, 0xCA8}, {0xCAA, 0xCB3},
{0xCB5, 0xCB9}, {0xCBC, 0xCC4}, {0xCC6, 0xCC8}, {0xCCA, 0xCCD},
{0xCE0, 0xCE3}, {0xCE6, 0xCEF}, {0xD00, 0xD0C}, {0xD0E, 0xD10},
{0xD12, 0xD44}, {0xD46, 0xD48}, {0xD4A, 0xD4F}, {0xD54, 0xD63},
{0xD66, 0xD7F}, {0xD81, 0xD83}, {0xD85, 0xD96}, {0xD9A, 0xDB1},
{0xDB3, 0xDBB}, {0xDC0, 0xDC6}, {0xDCF, 0xDD4}, {0xDD8, 0xDDF},
{0xDE6, 0xDEF}, {0xDF2, 0xDF4}, {0xE01, 0xE3A}, {0xE3F, 0xE5B},
{0xE86, 0xE8A}, {0xE8C, 0xEA3}, {0xEA7, 0xEBD}, {0xEC0, 0xEC4},
{0xEC8, 0xECD}, {0xED0, 0xED9}, {0xEDC, 0xEDF}, {0xF00, 0xF47},
{0xF49, 0xF6C}, {0xF71, 0xF97}, {0xF99, 0xFBC}, {0xFBE, 0xFCC},
{0xFCE, 0xFDA}, {0x1000, 0x10C5}, {0x10D0, 0x1248}, {0x124A, 0x124D},
{0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D},
{0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5},
{0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A},
{0x135D, 0x137C}, {0x1380, 0x1399}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD},
{0x1400, 0x167F}, {0x1681, 0x169C}, {0x16A0, 0x16F8}, {0x1700, 0x170C},
{0x170E, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C},
{0x176E, 0x1770}, {0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9},
{0x1800, 0x180D}, {0x1810, 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, 0x1AC0},
{0x1B00, 0x1B4B}, {0x1B50, 0x1B7C}, {0x1B80, 0x1BF3}, {0x1BFC, 0x1C37},
{0x1C3B, 0x1C49}, {0x1C4D, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7},
{0x1CD0, 0x1CFA}, {0x1D00, 0x1DF9}, {0x1DFB, 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, 0x20BF},
{0x20D0, 0x20F0}, {0x2100, 0x218B}, {0x2190, 0x2426}, {0x2440, 0x244A},
{0x2460, 0x2B73}, {0x2B76, 0x2B95}, {0x2B97, 0x2C2E}, {0x2C30, 0x2C5E},
{0x2C60, 0x2CF3}, {0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96},
{0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE},
{0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE},
{0x2DE0, 0x2E52}, {0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5},
{0x2FF0, 0x2FFB}, {0x3001, 0x303F}, {0x3041, 0x3096}, {0x3099, 0x30FF},
{0x3105, 0x312F}, {0x3131, 0x318E}, {0x3190, 0x31E3}, {0x31F0, 0x321E},
{0x3220, 0x9FFC}, {0xA000, 0xA48C}, {0xA490, 0xA4C6}, {0xA4D0, 0xA62B},
{0xA640, 0xA6F7}, {0xA700, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 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, 0xFBC1},
{0xFBD3, 0xFD3F}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFD},
{0xFE00, 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}, {0x10600, 0x10736}, {0x10740, 0x10755},
{0x10760, 0x10767}, {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},
{0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD}, {0x10F00, 0x10F27},
{0x10F30, 0x10F59}, {0x10FB0, 0x10FCB}, {0x10FE0, 0x10FF6}, {0x11000, 0x1104D},
{0x11052, 0x1106F}, {0x1107F, 0x110BC}, {0x110BE, 0x110C1}, {0x110D0, 0x110E8},
{0x110F0, 0x110F9}, {0x11100, 0x11134}, {0x11136, 0x11147}, {0x11150, 0x11176},
{0x11180, 0x111DF}, {0x111E1, 0x111F4}, {0x11200, 0x11211}, {0x11213, 0x1123E},
{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},
{0x11400, 0x1145B}, {0x1145D, 0x11461}, {0x11480, 0x114C7}, {0x114D0, 0x114D9},
{0x11580, 0x115B5}, {0x115B8, 0x115DD}, {0x11600, 0x11644}, {0x11650, 0x11659},
{0x11660, 0x1166C}, {0x11680, 0x116B8}, {0x116C0, 0x116C9}, {0x11700, 0x1171A},
{0x1171D, 0x1172B}, {0x11730, 0x1173F}, {0x11800, 0x1183B}, {0x118A0, 0x118F2},
{0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x11935}, {0x1193B, 0x11946},
{0x11950, 0x11959}, {0x119A0, 0x119A7}, {0x119AA, 0x119D7}, {0x119DA, 0x119E4},
{0x11A00, 0x11A47}, {0x11A50, 0x11AA2}, {0x11AC0, 0x11AF8}, {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}, {0x11FC0, 0x11FF1},
{0x11FFF, 0x12399}, {0x12400, 0x1246E}, {0x12470, 0x12474}, {0x12480, 0x12543},
{0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16A60, 0x16A69}, {0x16AD0, 0x16AED}, {0x16AF0, 0x16AF5}, {0x16B00, 0x16B45},
{0x16B50, 0x16B59}, {0x16B5B, 0x16B61}, {0x16B63, 0x16B77}, {0x16B7D, 0x16B8F},
{0x16E40, 0x16E9A}, {0x16F00, 0x16F4A}, {0x16F4F, 0x16F87}, {0x16F8F, 0x16F9F},
{0x16FE0, 0x16FE4}, {0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08},
{0x1B000, 0x1B11E}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB},
{0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99},
{0x1BC9C, 0x1BC9F}, {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172},
{0x1D17B, 0x1D1E8}, {0x1D200, 0x1D245}, {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}, {0x1E000, 0x1E006},
{0x1E008, 0x1E018}, {0x1E01B, 0x1E021}, {0x1E026, 0x1E02A}, {0x1E100, 0x1E12C},
{0x1E130, 0x1E13D}, {0x1E140, 0x1E149}, {0x1E2C0, 0x1E2F9}, {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}, {0x1F6E0, 0x1F6EC},
{0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F773}, {0x1F780, 0x1F7D8}, {0x1F7E0, 0x1F7EB},
{0x1F800, 0x1F80B}, {0x1F810, 0x1F847}, {0x1F850, 0x1F859}, {0x1F860, 0x1F887},
{0x1F890, 0x1F8AD}, {0x1F900, 0x1F978}, {0x1F97A, 0x1F9CB}, {0x1F9CD, 0x1FA53},
{0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA74}, {0x1FA78, 0x1FA7A}, {0x1FA80, 0x1FA86},
{0x1FA90, 0x1FAA8}, {0x1FAB0, 0x1FAB6}, {0x1FAC0, 0x1FAC2}, {0x1FAD0, 0x1FAD6},
{0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBCA}, {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DD},
{0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0},
{0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, {0xE0100, 0xE01EF}
#endif
};
#define NUM_GRAPH_RANGE (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, 0xCD5, 0xCD6, 0xCDE, 0xCF1, 0xCF2, 0xDBD, 0xDCA,
0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258,
0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071,
0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44,
0xFFFC, 0xFFFD
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x101A0, 0x1056F, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4,
0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1, 0x11288, 0x1130F, 0x11310,
0x11332, 0x11333, 0x11347, 0x11348, 0x11350, 0x11357, 0x11909, 0x11915, 0x11916,
0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A, 0x11D3C, 0x11D3D, 0x11D67, 0x11D68,
0x11D90, 0x11D91, 0x11FB0, 0x16A6E, 0x16A6F, 0x16FF0, 0x16FF1, 0x1D49E, 0x1D49F,
0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E023, 0x1E024, 0x1E14E, 0x1E14F,
0x1E2FF, 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, 0x1F8B0, 0x1F8B1
#endif
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
/*
* End of auto-generated Unicode character ranges declarations.
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 |
addchr(cv, alphaCharTable[i]);
}
}
break;
case CC_ASCII:
cv = getcvec(v, 0, 1);
if (cv) {
| | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
addchr(cv, alphaCharTable[i]);
}
}
break;
case CC_ASCII:
cv = getcvec(v, 0, 1);
if (cv) {
addrange(cv, 0, 0x7F);
}
break;
case CC_BLANK:
cv = getcvec(v, 2, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
|
| ︙ | ︙ |
Changes to generic/regc_nfa.c.
1 2 3 4 | /* * NFA utilities. * This file is #included by regcomp.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * NFA utilities. * This file is #included by regcomp.c. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regcomp.c.
1 2 3 4 | /* * re_*comp and friends - compile REs * This file #includes several others (see the bottom). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * re_*comp and friends - compile REs * This file #includes several others (see the bottom). * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | static void bracket(struct vars *, struct state *, struct state *); static void cbracket(struct vars *, struct state *, struct state *); static void brackpart(struct vars *, struct state *, struct state *); static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | static void bracket(struct vars *, struct state *, struct state *); static void cbracket(struct vars *, struct state *, struct state *); static void brackpart(struct vars *, struct state *, struct state *); static const chr *scanplain(struct vars *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); static void wordchrs(struct vars *); static struct subre *sub_re(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); static void freesrnode(struct vars *, struct subre *); static int numst(struct subre *, int); static void markst(struct subre *); static void cleanst(struct vars *); static long nfatree(struct vars *, struct subre *, FILE *); static long nfanode(struct vars *, struct subre *, FILE *); |
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
struct subre *branches; /* top level */
struct subre *branch; /* current branch */
struct subre *t; /* temporary */
int firstbranch; /* is this the first branch? */
assert(stopper == ')' || stopper == EOS);
| | | | 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 |
struct subre *branches; /* top level */
struct subre *branch; /* current branch */
struct subre *t; /* temporary */
int firstbranch; /* is this the first branch? */
assert(stopper == ')' || stopper == EOS);
branches = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branches;
firstbranch = 1;
do { /* a branch */
if (!firstbranch) {
/*
* Need a place to hang the branch.
*/
branch->right = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branch->right;
}
firstbranch = 0;
left = newstate(v->nfa);
right = newstate(v->nfa);
NOERRN();
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
{
struct state *lp; /* left end of current construct */
int seencontent; /* is there anything in this branch yet? */
struct subre *t;
lp = left;
seencontent = 0;
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
{
struct state *lp; /* left end of current construct */
int seencontent; /* is there anything in this branch yet? */
struct subre *t;
lp = left;
seencontent = 0;
t = sub_re(v, '=', 0, left, right); /* op '=' is tentative */
NOERRN();
while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) {
if (seencontent) { /* implicit concat operator */
lp = newstate(v->nfa);
NOERRN();
moveins(v->nfa, right, lp);
}
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
/*
* Initial bookkeeping.
*/
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
| | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
/*
* Initial bookkeeping.
*/
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
subno = 0;
/*
* An atom or constraint...
*/
atomtype = v->nexttype;
switch (atomtype) {
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
NOERR();
atom = parse(v, ')', PLAIN, s, s2);
assert(SEE(')') || ISERR());
NEXT();
NOERR();
if (cap) {
v->subs[subno] = atom;
| | | | 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 |
NOERR();
atom = parse(v, ')', PLAIN, s, s2);
assert(SEE(')') || ISERR());
NEXT();
NOERR();
if (cap) {
v->subs[subno] = atom;
t = sub_re(v, '(', atom->flags|CAP, lp, rp);
NOERR();
t->subno = subno;
t->left = atom;
atom = t;
}
/*
* Postpone everything else pending possible {0}.
*/
break;
case BACKREF: /* the Feature From The Black Lagoon */
INSIST(type != LACON, REG_ESUBREG);
INSIST(v->nextvalue < v->nsubs, REG_ESUBREG);
INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG);
NOERR();
assert(v->nextvalue > 0);
atom = sub_re(v, 'b', BACKR, lp, rp);
NOERR();
subno = v->nextvalue;
atom->subno = subno;
EMPTYARC(lp, rp); /* temporarily, so there's something */
NEXT();
break;
}
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
*/
/*
* Now we'll need a subre for the contents even if they're boring.
*/
if (atom == NULL) {
| | | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
*/
/*
* Now we'll need a subre for the contents even if they're boring.
*/
if (atom == NULL) {
atom = sub_re(v, '=', 0, lp, rp);
NOERR();
}
/*
* Prepare a general-purpose state skeleton.
*
* In the no-backrefs case, we want this:
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
EMPTYARC(lp, s);
NOERR();
/*
* Break remaining subRE into x{...} and what follows.
*/
| | | | 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 |
EMPTYARC(lp, s);
NOERR();
/*
* Break remaining subRE into x{...} and what follows.
*/
t = sub_re(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
NOERR();
t->left = atom;
atomp = &t->left;
/*
* Here we should recurse... but we must postpone that to the end.
*/
/*
* Split top into prefix and remaining.
*/
assert(top->op == '=' && top->left == NULL && top->right == NULL);
top->left = sub_re(v, '=', top->flags, top->begin, lp);
NOERR();
top->op = '.';
top->right = t;
/*
* If it's a backref, now is the time to replicate the subNFA.
*/
|
| ︙ | ︙ | |||
1226 1227 1228 1229 1230 1231 1232 | * we don't really care where its submatches are. */ dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin); assert(m >= 1 && m != DUPINF && n >= 1); repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1); f = COMBINE(qprefer, atom->flags); | | | | | | 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 |
* we don't really care where its submatches are.
*/
dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin);
assert(m >= 1 && m != DUPINF && n >= 1);
repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1);
f = COMBINE(qprefer, atom->flags);
t = sub_re(v, '.', f, s, atom->end); /* prefix and atom */
NOERR();
t->left = sub_re(v, '=', PREF(f), s, atom->begin);
NOERR();
t->right = atom;
*atomp = t;
/* rest of branch can be strung starting from atom->end */
s2 = atom->end;
} else {
/* general case: need an iteration node */
s2 = newstate(v->nfa);
NOERR();
moveouts(v->nfa, atom->end, s2);
NOERR();
dupnfa(v->nfa, atom->begin, atom->end, s, s2);
repeat(v, s, s2, m, n);
f = COMBINE(qprefer, atom->flags);
t = sub_re(v, '*', f, s, s2);
NOERR();
t->min = (short) m;
t->max = (short) n;
t->left = atom;
*atomp = t;
/* rest of branch is to be strung from iteration's end state */
}
/*
* And finally, look after that postponed recursion.
*/
t = top->right;
if (!(SEE('|') || SEE(stopper) || SEE(EOS))) {
t->right = parsebranch(v, stopper, type, s2, rp, 1);
} else {
EMPTYARC(s2, rp);
t->right = sub_re(v, '=', 0, s2, rp);
}
NOERR();
assert(SEE('|') || SEE(stopper) || SEE(EOS));
t->flags |= COMBINE(t->flags, t->right->flags);
top->flags |= COMBINE(top->flags, t->flags);
}
|
| ︙ | ︙ | |||
1713 1714 1715 1716 1717 1718 1719 |
assert((v->savenow != NULL && SEE(']')) || ISERR());
NEXT();
NOERR();
v->wordchrs = left;
}
/*
| | | | | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
assert((v->savenow != NULL && SEE(']')) || ISERR());
NEXT();
NOERR();
v->wordchrs = left;
}
/*
- sub_re - allocate a subre
^ static struct subre *sub_re(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
sub_re(
struct vars *v,
int op,
int flags,
struct state *begin,
struct state *end)
{
struct subre *ret = v->treefree;
|
| ︙ | ︙ |
Changes to generic/regcustom.h.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ | | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ #define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ #define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* * Functions operating on chr. */ #define iscalnum(x) Tcl_UniCharIsAlnum(x) |
| ︙ | ︙ |
Changes to generic/rege_dfa.c.
1 2 3 4 | /* * DFA routines * This file is #included by regexec.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 | /* * DFA routines * This file is #included by regexec.c. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regerror.c.
1 2 3 | /* * regerror - error-code expansion * | | | 1 2 3 4 5 6 7 8 9 10 11 | /* * regerror - error-code expansion * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
#include "regerrs.h"
{ -1, "", "oops" }, /* explanation special-cased in code */
};
/*
- regerror - the interface to error numbers
*/
| < | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
#include "regerrs.h"
{ -1, "", "oops" }, /* explanation special-cased in code */
};
/*
- regerror - the interface to error numbers
*/
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
char *errbuf, /* Result buffer (unless errbuf_size==0) */
size_t errbuf_size) /* Available space in errbuf, can be 0 */
{
const struct rerr *r;
|
| ︙ | ︙ |
Changes to generic/regexec.c.
1 2 3 | /* * re_*exec and friends - match REs * | | | 1 2 3 4 5 6 7 8 9 10 11 | /* * re_*exec and friends - match REs * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
struct sset *search; /* replacement-search-pointer memory */
int cptsmalloced; /* were the areas individually malloced? */
| | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
struct arcp *incarea; /* inchain storage */
struct cnfa *cnfa;
struct colormap *cm;
chr *lastpost; /* location of last cache-flushed success */
chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
struct sset *search; /* replacement-search-pointer memory */
int cptsmalloced; /* were the areas individually malloced? */
char *mallocarea; /* self, or malloced area, or NULL */
};
#define WORK 1 /* number of work bitvectors needed */
/*
* Setup for non-malloc allocation for small cases.
*/
|
| ︙ | ︙ |
Changes to generic/regfree.c.
1 2 3 | /* * regfree - free an RE * | | | 1 2 3 4 5 6 7 8 9 10 11 | /* * regfree - free an RE * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regfronts.c.
1 2 3 4 5 6 | /* * regcomp and regexec - front ends to re_ routines * * Mostly for implementation of backward-compatibility kludges. Note that * these routines exist ONLY in char versions. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * regcomp and regexec - front ends to re_ routines * * Mostly for implementation of backward-compatibility kludges. Note that * these routines exist ONLY in char versions. * * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ |
Changes to generic/regguts.h.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | */ #define NOTREACHED 0 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
*/
#define NOTREACHED 0
#define DUPMAX _POSIX2_RE_DUP_MAX
#define DUPINF (DUPMAX+1)
#define REMAGIC 0xFED7 /* magic number for main struct */
/*
* debugging facilities
*/
#ifdef REG_DEBUG
/* FDEBUG does finite-state tracing */
#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; }
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
| | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
#define GUTSMAGIC 0xFED9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
|
| ︙ | ︙ |
Changes to generic/tcl.decls.
1 2 3 4 5 6 7 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h # and tclStubInit.c files. # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h # and tclStubInit.c files. # # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved. # Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. library tcl # Define the tcl interface with several sub interfaces: |
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
int Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
int flags)
}
declare 86 {
| | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
int Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd,
Tcl_Interp *target, const char *targetCmd, int objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
const char *chanName, ClientData instanceData, int mask)
}
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
| | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData)
}
declare 99 {
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 {
| | | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
| | | | | | 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 |
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp)
}
declare 164 {
Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we include it here for compatibility reasons.
declare 167 unix {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
declare 170 {
int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
| | | | 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 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
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 405 {deprecated {Use Tcl_ChannelWideSeekProc}} {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr)
}
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) | < | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 4 |
| ︙ | ︙ | |||
357 358 359 360 361 362 363 | * * Note on converting between Tcl_WideInt and strings. This implementation (in * tclObj.c) depends on the function * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | * * Note on converting between Tcl_WideInt and strings. This implementation (in * tclObj.c) depends on the function * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO) # define TCL_WIDE_INT_TYPE __int64 # define TCL_LL_MODIFIER "I64" # if defined(_WIN64) # define TCL_Z_MODIFIER "I" # endif # elif defined(__GNUC__) # define TCL_Z_MODIFIER "z" |
| ︙ | ︙ | |||
969 970 971 972 973 974 975 | * that condition. */ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* | | | > > | > | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 | * that condition. */ #define TCL_DONT_USE_BRACES 1 #define TCL_DONT_QUOTE_HASH 8 /* * Flags that may be passed to Tcl_GetIndexFromObj. * TCL_EXACT disallows abbreviated strings. * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. */ #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * |
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 | #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *) 1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc. */ #define TCL_CHANNEL_THREAD_INSERT (0) | > > | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 | #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *) 1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #ifndef TCL_NO_DEPRECATED #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) #endif #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc. */ #define TCL_CHANNEL_THREAD_INSERT (0) |
| ︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 |
const char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by channel
* type. */
Tcl_ChannelTypeVersion version;
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
| | | 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 |
const char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by channel
* type. */
Tcl_ChannelTypeVersion version;
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
* NULL or TCL_CLOSE2PROC if the close2Proc should be
* used instead. */
Tcl_DriverInputProc *inputProc;
/* Function to call for input on channel. */
Tcl_DriverOutputProc *outputProc;
/* Function to call for output on channel. */
Tcl_DriverSeekProc *seekProc;
/* Function to call to seek on the channel.
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 | #define TCL_CONVERT_UNKNOWN (-3) #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4 * (or perhaps 1 if we want to support a non-unicode enabled core). If 3, | | | | 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 | #define TCL_CONVERT_UNKNOWN (-3) #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4 * (or perhaps 1 if we want to support a non-unicode enabled core). If 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16) (the default). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UTF-16 mode * is the default and recommended mode. */ #ifndef TCL_UTF_MAX #define TCL_UTF_MAX 3 #endif |
| ︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 |
* Use do/while0 idiom for optimum correctness without compiler warnings.
* http://c2.com/cgi/wiki?TrivialDoWhileLoop
*/
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
| | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
* Use do/while0 idiom for optimum correctness without compiler warnings.
* http://c2.com/cgi/wiki?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)
#endif
|
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
1 2 3 4 5 6 7 8 | /* * tclAlloc.c -- * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. Blocks * over a certain size are directly allocated from the system. * | | | | | | 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 | /* * tclAlloc.c -- * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. Blocks * over a certain size are directly allocated from the system. * * Copyright © 1983 Regents of the University of California. * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" #if !TCL_THREADS || !defined(USE_THREAD_ALLOC) #if defined(USE_TCLALLOC) && USE_TCLALLOC /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #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 #define RSLOP 0 #endif |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
union overhead *overPtr;
size_t bucket;
unsigned amount;
struct block *bigBlockPtr = NULL;
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 | bigBlockPtr->nextPtr = bigBlocks.nextPtr; bigBlocks.nextPtr = bigBlockPtr; bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | bigBlockPtr->nextPtr = bigBlocks.nextPtr; bigBlocks.nextPtr = bigBlockPtr; bigBlockPtr->prevPtr = &bigBlocks; bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; overPtr = (union overhead *) (bigBlockPtr + 1); overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; overPtr->bucketIndex = 0xFF; #ifdef MSTATS numMallocs[NBUCKETS]++; #endif #ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
| | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
overPtr->bucketIndex = UCHAR(bucket);
#ifdef MSTATS
numMallocs[bucket]++;
#endif
#ifndef NDEBUG
/*
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 | * None. * *---------------------------------------------------------------------- */ void TclpFree( | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
size_t size;
union overhead *overPtr;
struct block *bigBlockPtr;
if (oldPtr == NULL) {
return;
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
size = overPtr->bucketIndex;
| | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
size = overPtr->bucketIndex;
if (size == 0xFF) {
#ifdef MSTATS
numMallocs[NBUCKETS]--;
#endif
bigBlockPtr = (struct block *) overPtr - 1;
bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
size_t maxSize;
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
if (i == 0xFF) {
struct block *prevPtr, *nextPtr;
bigBlockPtr = (struct block *) overPtr - 1;
prevPtr = bigBlockPtr->prevPtr;
nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + numBytes);
if (bigBlockPtr == NULL) {
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | | 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 |
*/
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (void *)(overPtr+1);
}
maxSize = 1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
} else if (i>0 && numBytes+OVERHEAD < maxSize/2) {
expensive = 1;
}
if (expensive) {
void *newPtr;
Tcl_MutexUnlock(allocMutexPtr);
newPtr = TclpAlloc(numBytes);
if (newPtr == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
return malloc(numBytes);
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Free memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclAssembly.c.
1 2 3 4 5 6 7 8 | /* * tclAssembly.c -- * * Assembler for Tcl bytecodes. * * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclAssembly.c -- * * Assembler for Tcl bytecodes. * * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * * Copyright © 2010 Ozgur Dogan Ugurlu. * Copyright © 2010 Kevin B. Kenny. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /*- *- THINGS TO DO: |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | * stack. */ }; /* * Source instruction type recognized by the assembler. */ | | < < | 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 |
* stack. */
};
/*
* Source instruction type recognized by the assembler.
*/
typedef enum {
ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be
* converted to appropriate exception
* ranges */
ASSEM_BOOL, /* One Boolean operand */
ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */
ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the
* range 0-3 */
ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must
* be strictly positive, consumes N, produces
* 1 */
ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1
* operands, produces 1, N > 0 */
ASSEM_DICT_SET, /* specifies key count and LVT index, consumes
* N+1 operands, produces 1, N > 0 */
ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes
* N operands, produces 1, N > 0 */
ASSEM_END_CATCH, /* End catch. No args. Exception range popped
* from stack and stack pointer restored. */
ASSEM_EVAL, /* 'eval' - evaluate a constant script (by
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
ASSEM_PUSH, /* one literal operand */
ASSEM_REGEXP, /* One Boolean operand, but weird mapping to
* call flags */
ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N,
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
| | > > | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
ASSEM_PUSH, /* one literal operand */
ASSEM_REGEXP, /* One Boolean operand, but weird mapping to
* call flags */
ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N,
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
* LVT entry. Fixed arity */
ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2
* operands, produces 1, N > 0 */
} TalInstType;
/*
* Description of an instruction recognized by the assembler.
*/
typedef struct TalInstDesc {
|
| ︙ | ︙ | |||
672 673 674 675 676 677 678 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
| | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode & 0xFF;
/*
* If this is the first instruction in a basic block, record its line
* number.
*/
if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
| | | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
if (param <= 0xFF) {
op >>= 8;
} else {
op &= 0xFF;
}
TclEmitInt1(op, envPtr);
if (param <= 0xFF) {
TclEmitInt1(param, envPtr);
} else {
TclEmitInt4(param, envPtr);
}
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 | * include whatever the code does. * *----------------------------------------------------------------------------- */ int Tcl_AssembleObjCmd( | | | | < | | 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 |
* include whatever the code does.
*
*-----------------------------------------------------------------------------
*/
int
Tcl_AssembleObjCmd(
ClientData clientData, /* clientData */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Boilerplate - make sure that there is an NRE trampoline on the C stack
* because there needs to be one in place to execute bytecode.
*/
return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv);
}
int
TclNRAssembleObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ByteCode *codePtr; /* Pointer to the bytecode to execute */
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
}
/*
* Assemble the source to bytecode.
*/
codePtr = CompileAssembleObj(interp, objv[1]);
/*
* On failure, report error line.
*/
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
TclNewIntObj(backtrace, Tcl_GetErrorLine(interp));
Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
/*
* Use NRE to evaluate the bytecode from the trampoline.
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 |
*/
int
TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
*/
int
TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
/*
* Make sure that the command has a single arg that is a simple word.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
/* Tcl interpreter */
Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
/* Parse of the line of code */
Tcl_Token* tokenPtr; /* Current token within the line of code */
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
| | | 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 |
/* Tcl interpreter */
Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
/* Parse of the line of code */
Tcl_Token* tokenPtr; /* Current token within the line of code */
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
int operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
int localVar; /* LVT index of a local variable */
|
| ︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
{
| < < | | 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
{
BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0);
}
break;
case ASSEM_REVERSE:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
|
| ︙ | ︙ | |||
2099 2100 2101 2102 2103 2104 2105 |
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding
* the operand */
Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text
* with \-substitutions done. */
{
Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
| | > | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 |
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding
* the operand */
Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text
* with \-substitutions done. */
{
Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
Tcl_Obj* operandObj;
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", NULL);
}
|
| ︙ | ︙ | |||
2234 2235 2236 2237 2238 2239 2240 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: | | | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: * Stores the list index at '*index'. Values between -1 and 0x7FFFFFFF * have their natural meaning; values between -2 and -0x80000000 * represent 'end-2-N'. * *----------------------------------------------------------------------------- */ static int |
| ︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
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", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2432 2433 2434 2435 2436 2437 2438 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
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", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 |
* target is out of range.
*/
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
| | | 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 |
* target is out of range.
*/
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
if (offset < -0x80 || offset > 0x7F) {
opcode = TclGetUInt1AtPtr(envPtr->codeStart
+ bbPtr->jumpOffset);
++opcode;
TclStoreInt1AtPtr(opcode,
envPtr->codeStart + bbPtr->jumpOffset);
motion += 3;
bbPtr->flags &= ~BB_JUMP1;
|
| ︙ | ︙ | |||
4270 4271 4272 4273 4274 4275 4276 |
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
| | | 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 |
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
TclNewIntObj(lineNo, bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
TclSetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
|
| ︙ | ︙ | |||
4312 4313 4314 4315 4316 4317 4318 | * None. * *----------------------------------------------------------------------------- */ static void DupAssembleCodeInternalRep( | | | < < | 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 |
* None.
*
*-----------------------------------------------------------------------------
*/
static void
DupAssembleCodeInternalRep(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj *))
{
return;
}
/*
*-----------------------------------------------------------------------------
*
* FreeAssembleCodeInternalRep --
|
| ︙ | ︙ |
Changes to generic/tclAsync.c.
1 2 3 4 5 6 7 | /* * tclAsync.c -- * * This file provides low-level support needed to invoke signal handlers * in a safe way. The code here doesn't actually handle signals, though. * This code is based on proposals made by Mark Diekhans and Don Libes. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclAsync.c -- * * This file provides low-level support needed to invoke signal handlers * in a safe way. The code here doesn't actually handle signals, though. * This code is based on proposals made by Mark Diekhans and Don Libes. * * Copyright © 1993 The Regents of the University of California. * Copyright © 1994 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" |
| ︙ | ︙ |
Changes to generic/tclBasic.c.
1 2 3 4 5 6 7 | /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * * Copyright © 1987-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net> * * 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 "tclOOInt.h" |
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
typedef struct {
Tcl_Interp *interp; /* Interp this struct belongs to. */
Tcl_AsyncHandler async; /* Async handler token for script
* cancellation. */
char *result; /* The script cancellation result or NULL for
* a default result. */
int length; /* Length of the above error message. */
| | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
typedef struct {
Tcl_Interp *interp; /* Interp this struct belongs to. */
Tcl_AsyncHandler async; /* Async handler token for script
* cancellation. */
char *result; /* The script cancellation result or NULL for
* a default result. */
int length; /* Length of the above error message. */
ClientData clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);
/*
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
| | | | | | | | | | | | | | | | | | | 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 |
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
double (*fn)(double x); /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
{ "acos", ExprUnaryFunc, acos },
{ "asin", ExprUnaryFunc, asin },
{ "atan", ExprUnaryFunc, atan },
{ "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) 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, (double (*)(double))(void *)(double (*)(double, double)) fmod},
{ "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) 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, (double (*)(double))(void *)(double (*)(double, double)) 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.
*/
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
/*
* Panic if someone updated the CallFrame structure without also updating
* the Tcl_CallFrame structure (or vice versa).
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
| < < | | | | | | | | 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 |
/*
* Panic if someone updated the CallFrame structure without also updating
* the Tcl_CallFrame structure (or vice versa).
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T)
/* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T
* the result is a binary incompatible with the 'standard' build of
* Tcl: All extensions using Tcl_StatBuf need to be recompiled in
* the same way. Therefore, this is not officially supported.
* In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
*/
if ((offsetof(Tcl_StatBuf,st_atime) != 32)
|| (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
cancelTableInitialized = 1;
}
Tcl_MutexUnlock(&cancelLock);
}
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.
*/
iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
#ifdef TCL_NO_DEPRECATED
iPtr->result = &tclEmptyString;
#else
iPtr->result = iPtr->resultSpace;
#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
TclNewObj(iPtr->objResultPtr);
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->handle = TclHandleCreate(iPtr);
iPtr->globalNsPtr = NULL;
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable));
iPtr->extra.optimizer = TclOptimizeBytecode;
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL; /* Initialise as soon as :: is available */
iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
* structures.
*/
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
iPtr->scriptCLLocPtr = NULL;
iPtr->activeVarTracePtr = NULL;
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
| < | | 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
/*
* Initialise the rootCallframe. It cannot be allocated on the stack, as
* it has to be in place before TclCreateExecEnv tries to use a variable.
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
| | | 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
/*
* Initialise the rootCallframe. It cannot be allocated on the stack, as
* it has to be in place before TclCreateExecEnv tries to use a variable.
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
framePtr = (CallFrame *)ckalloc(sizeof(CallFrame));
(void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
framePtr->objc = 0;
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
iPtr->rootFramePtr = framePtr;
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
iPtr->chanMsg = NULL;
/*
* TIP #285, Script cancellation support.
*/
| | | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
iPtr->chanMsg = NULL;
/*
* TIP #285, Script cancellation support.
*/
TclNewObj(iPtr->asyncCancelMsg);
cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo));
cancelInfo->interp = interp;
iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
cancelInfo->async = iPtr->asyncCancel;
cancelInfo->result = NULL;
cancelInfo->length = 0;
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
/*
* Initialise the thread-specific data ekeko. Note that the thread's alloc
* cache was already initialised by the call to alloc the interp struct.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
| | | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
/*
* Initialise the thread-specific data ekeko. Note that the thread's alloc
* cache was already initialised by the call to alloc the interp struct.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
iPtr->deferredCallbacks = NULL;
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
| | | 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
cmdPtr = (Command *)ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = cmdInfoPtr->compileProc;
cmdPtr->proc = TclInvokeObjectCommand;
cmdPtr->clientData = cmdPtr;
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 |
}
#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,
| | | | 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 |
}
#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("can't 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 *)ckalloc(sizeof(TclOpCmdClientData));
occdPtr->op = opcmdInfoPtr->name;
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
occdPtr->expected = opcmdInfoPtr->expected;
strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name);
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData);
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
| > | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
|
| ︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 |
return interp;
}
static void
DeleteOpCmdClientData(
ClientData clientData)
{
| | | 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
return interp;
}
static void
DeleteOpCmdClientData(
ClientData clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
ckfree(occdPtr);
}
/*
* ---------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1256 1257 1258 1259 1260 1261 1262 |
}
const char *
TclGetCommandTypeName(
Tcl_Command command)
{
Command *cmdPtr = (Command *) command;
| | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
}
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) {
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 |
|| Tcl_HideCommand(interp, "___tmp",
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
unsafePtr->ensembleNsName, unsafePtr->commandName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
Tcl_CreateObjCommand(interp, TclGetString(cmdName),
| | | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
|| Tcl_HideCommand(interp, "___tmp",
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
unsafePtr->ensembleNsName, unsafePtr->commandName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
Tcl_CreateObjCommand(interp, TclGetString(cmdName),
BadEnsembleSubcommand, (void *)unsafePtr, NULL);
TclDecrRefCount(cmdName);
TclDecrRefCount(hideName);
} else {
/*
* Hide an ensemble main command (for compatibility).
*/
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
*----------------------------------------------------------------------
*/
static int
BadEnsembleSubcommand(
ClientData clientData,
Tcl_Interp *interp,
| | | | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 |
*----------------------------------------------------------------------
*/
static int
BadEnsembleSubcommand(
ClientData clientData,
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", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
ClientData clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
| | | | | 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 |
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
ClientData 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 *)ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == NULL) {
iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 |
hTablePtr = iPtr->assocData;
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 |
hTablePtr = iPtr->assocData;
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
return;
}
}
}
|
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
| | | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
if (isNew == 0) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
} else {
dPtr = (AssocData *)ckalloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 |
if (iPtr->assocData == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return;
}
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
if (iPtr->assocData == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return;
}
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
}
|
| ︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 |
if (iPtr->assocData == NULL) {
return NULL;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return NULL;
}
| | | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
if (iPtr->assocData == NULL) {
return NULL;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return NULL;
}
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (procPtr != NULL) {
*procPtr = dPtr->proc;
}
return dPtr->clientData;
}
/*
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
| | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
if (cancelInfo != NULL) {
if (cancelInfo->result != NULL) {
ckfree(cancelInfo->result);
}
ckfree(cancelInfo);
}
|
| ︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 |
* to create any new hidden or non-hidden commands.
* Tcl_DeleteCommandFromToken will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | 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 |
* to create any new hidden or non-hidden commands.
* Tcl_DeleteCommandFromToken will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
}
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
*/
while (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
iPtr->assocData = NULL;
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);
}
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
|
| ︙ | ︙ | |||
1930 1931 1932 1933 1934 1935 1936 |
* TIP #280 - Release the arrays for ByteCode/Proc extension, and
* contents.
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
* TIP #280 - Release the arrays for ByteCode/Proc extension, and
* contents.
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
CmdFrame *cfPtr = (CmdFrame *)Tcl_GetHashValue(hPtr);
Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
procPtr->iPtr = NULL;
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
}
|
| ︙ | ︙ | |||
1954 1955 1956 1957 1958 1959 1960 |
/*
* See also tclCompile.c, TclCleanupByteCode
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 |
/*
* See also tclCompile.c, TclCleanupByteCode
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0; i< eclPtr->nuloc; i++) {
ckfree(eclPtr->loc[i].line);
}
|
| ︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
| | | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
/*
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
| ︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
}
| | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, 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).
*/
|
| ︙ | ︙ | |||
2454 2455 2456 2457 2458 2459 2460 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
| | | 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
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.
*/
|
| ︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = TclInvokeStringCommand;
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
| | | 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData *)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
|
| ︙ | ︙ | |||
2673 2674 2675 2676 2677 2678 2679 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
| | | 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* [***] This is wrong. See Tcl Bug a16752c252.
* However, this buggy behavior is kept under particular circumstances
* to accommodate deployed binaries of the "tclcompiler" program
* <http://sourceforge.net/projects/tclpro/> that crash if the bug is
* fixed.
|
| ︙ | ︙ | |||
2754 2755 2756 2757 2758 2759 2760 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = proc;
|
| ︙ | ︙ | |||
2782 2783 2784 2785 2786 2787 2788 |
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
| | > > | 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 |
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
cmdPtr->refCount++;
TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
|
| ︙ | ︙ | |||
2827 2828 2829 2830 2831 2832 2833 |
int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 |
int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr = (Command *)clientData;
int i, result;
const char **argv = (const char **)
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
|
| ︙ | ︙ | |||
2875 2876 2877 2878 2879 2880 2881 |
int
TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
| | | | 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
int
TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Command *cmdPtr = ( Command *) clientData;
Tcl_Obj *objPtr;
int i, length, result;
Tcl_Obj **objv = (Tcl_Obj **)
TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *)));
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewStringObj(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
objv[i] = objPtr;
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
| | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 |
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
TclNewObj(oldFullName);
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* Make sure that the destination command does not already exist. The
* rename operation is like creating a command, so we should automatically
* create the containing namespaces just like Tcl_CreateCommand would.
|
| ︙ | ︙ | |||
3313 3314 3315 3316 3317 3318 3319 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_GetCommandName( | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_GetCommandName(
TCL_UNUSED(Tcl_Interp *),
Tcl_Command command) /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
{
Command *cmdPtr = (Command *) command;
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
/*
* This should only happen if command was "created" after the
* interpreter began to be deleted, so there isn't really any command.
* Just return an empty string.
*/
return "";
}
return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFullName --
*
|
| ︙ | ︙ | |||
3372 3373 3374 3375 3376 3377 3378 |
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
| | | | 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 |
char *name;
/*
* 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, -1);
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, -1);
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
* as OTcl). However, this means that the callback could try to delete or
* rename the command. The deleted flag allows us to detect these cases
* and skip nested deletes.
*/
| | | 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 |
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
* as OTcl). However, this means that the callback could try to delete or
* rename the command. The deleted flag allows us to detect these cases
* and skip nested deletes.
*/
if (cmdPtr->flags & CMD_DYING) {
/*
* Another deletion is already in progress. Remove the hash table
* entry now, but don't invoke a callback or free the command
* structure. Take care to only remove the hash entry if it has not
* already been removed; otherwise if we manage to hit this function
* three times, everything goes up in smoke. [Bug 1220058]
*/
|
| ︙ | ︙ | |||
3494 3495 3496 3497 3498 3499 3500 |
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
* delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
| | | 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 |
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
* delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
cmdPtr->flags |= CMD_DYING;
/*
* Call trace functions for the command being deleted. Then delete its
* traces.
*/
cmdPtr->nsPtr->refCount++;
|
| ︙ | ︙ | |||
3524 3525 3526 3527 3528 3529 3530 |
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
| | > > > > > > > > > > > > > < < < < < < < < < < < < < < | 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 |
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
* The list of commands exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we need
* the info will be soon enough.
*/
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
/*
* If the command being deleted has a compile function, increment the
* interpreter's compileEpoch to invalidate its compiled code. This makes
* sure that we don't later try to execute old code compiled with
* command-specific (i.e., inline) bytecodes for the now-deleted command.
* This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose
* compilation epoch doesn't match is recompiled.
*/
if (cmdPtr->compileProc != NULL) {
iPtr->compileEpoch++;
}
if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) {
/*
* Delete any imports of this routine before deleting this routine itself.
* See issue 688fcc7082fa.
*/
for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
refPtr = nextRefPtr) {
nextRefPtr = refPtr->nextPtr;
importCmd = (Tcl_Command) refPtr->importedCmdPtr;
Tcl_DeleteCommandFromToken(interp, importCmd);
}
}
if (cmdPtr->deleteProc != NULL) {
/*
* Delete the command's client data. If this was an imported command
* created when a command was imported into a namespace, this client
* data will be a pointer to a ImportedCmdData structure describing
* the "real" command that this imported command refers to.
*
* If you are getting a crash during the call to deleteProc and
* cmdPtr->deleteProc is a pointer to the function free(), the most
* likely cause is that your extension allocated memory for the
* clientData argument to Tcl_CreateObjCommand with the ckalloc()
* macro and you are now trying to deallocate this memory with free()
* instead of ckfree(). You should pass a pointer to your own method
* that calls ckfree().
*/
cmdPtr->deleteProc(cmdPtr->deleteData);
}
/*
* Don't use hPtr to delete the hash entry here, because it's possible
* that the deletion callback renamed the command. Instead, use
* cmdPtr->hptr, and make sure that no-one else has already deleted the
* hash entry.
|
| ︙ | ︙ | |||
3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 |
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
* CmdName Command reference is found to be invalid and
* TclNRExecuteByteCode looks up the command in the command hashtable).
*/
TclCleanupCommandMacro(cmdPtr);
return 0;
}
/*
*----------------------------------------------------------------------
*
| > | 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 |
* from a CmdName Tcl object in some ByteCode code sequence. In that case,
* delay the cleanup until all references are either discarded (when a
* ByteCode is freed) or replaced by a new reference (when a cached
* CmdName Command reference is found to be invalid and
* TclNRExecuteByteCode looks up the command in the command hashtable).
*/
cmdPtr->flags |= CMD_DEAD;
TclCleanupCommandMacro(cmdPtr);
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3659 3660 3661 3662 3663 3664 3665 |
Tcl_InterpState state = NULL;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
| | | 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 |
Tcl_InterpState state = NULL;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
* (cmdPtr->flags & CMD_DYING) and returns immediately when a
* command deletion is in progress. For all other traces, delete
* traces will not be invoked but a call to TraceCommandProc will
* ensure that tracePtr->clientData is freed whenever the command
* "oldName" is deleted.
*/
if (cmdPtr->flags & TCL_TRACE_RENAME) {
|
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 |
*
*----------------------------------------------------------------------
*/
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
| | | | 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 |
*
*----------------------------------------------------------------------
*/
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
CancelInfo *cancelInfo = (CancelInfo *)clientData;
Interp *iPtr;
if (cancelInfo != NULL) {
Tcl_MutexLock(&cancelLock);
iPtr = (Interp *) cancelInfo->interp;
if (iPtr != NULL) {
|
| ︙ | ︙ | |||
3790 3791 3792 3793 3794 3795 3796 | * just in case the caller passed flags that might cause behaviour * unrelated to script cancellation. */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* | | | | 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 | * just in case the caller passed flags that might cause behaviour * unrelated to script cancellation. */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* * Now, we must set the script cancellation flags on all the child * interpreters belonging to this one. */ TclSetChildCancelFlags((Tcl_Interp *) iPtr, cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid * locking the cancelLock mutex. */ |
| ︙ | ︙ | |||
3884 3885 3886 3887 3888 3889 3890 |
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
ClientData clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
| | | | 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 |
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
ClientData clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData));
data->proc = proc;
data->numArgs = numArgs;
data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
Tcl_DStringInit(&bigName);
TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::");
Tcl_DStringAppend(&bigName, name, -1);
|
| ︙ | ︙ | |||
3926 3927 3928 3929 3930 3931 3932 |
ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
Tcl_Obj *valuePtr;
| | | | 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 |
ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
Tcl_Obj *valuePtr;
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
Tcl_Value funcResult, *args;
int result;
int j, k;
double d;
/*
* Check argument count.
*/
if (objc != dataPtr->numArgs + 1) {
MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv);
return TCL_ERROR;
}
/*
* Convert arguments from Tcl_Obj's to Tcl_Value's.
*/
args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
/* TODO: Convert to TclGetNumberFromObj? */
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
if (result != TCL_OK) {
const Tcl_ObjIntRep *irPtr
|
| ︙ | ︙ | |||
4039 4040 4041 4042 4043 4044 4045 |
/*
* Return the result of the call.
*/
if (funcResult.type == TCL_INT) {
TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
| | | 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 |
/*
* Return the result of the call.
*/
if (funcResult.type == TCL_INT) {
TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
TclNewIntObj(valuePtr, funcResult.wideValue);
} else {
return CheckDoubleResult(interp, funcResult.doubleValue);
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4068 4069 4070 4071 4072 4073 4074 |
*----------------------------------------------------------------------
*/
static void
OldMathFuncDeleteProc(
ClientData clientData)
{
| | | 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 |
*----------------------------------------------------------------------
*/
static void
OldMathFuncDeleteProc(
ClientData clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
ckfree(dataPtr->argTypes);
ckfree(dataPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4141 4142 4143 4144 4145 4146 4147 |
/*
* Retrieve function info for user defined functions; return dummy
* information for builtins.
*/
if (cmdPtr->objProc == &OldMathFuncProc) {
| | | 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 |
/*
* Retrieve function info for user defined functions; return dummy
* information for builtins.
*/
if (cmdPtr->objProc == &OldMathFuncProc) {
OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData;
*procPtr = dataPtr->proc;
*numArgsPtr = dataPtr->numArgs;
*argTypesPtr = dataPtr->argTypes;
*clientDataPtr = dataPtr->clientData;
} else {
*procPtr = NULL;
|
| ︙ | ︙ | |||
4198 4199 4200 4201 4202 4203 4204 |
}
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_IncrRefCount(script);
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
| | | 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 |
}
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_IncrRefCount(script);
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
TclNewObj(result);
}
Tcl_DecrRefCount(script);
Tcl_RestoreInterpState(interp, state);
return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
|
| ︙ | ︙ | |||
4319 4320 4321 4322 4323 4324 4325 | /* *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., | | | 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 | /* *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., * Tcl_CancelEval was called for this interpreter or any of its parent * interpreters. * * Results: * The return value is TCL_OK if the script evaluation has not been * canceled, TCL_ERROR otherwise. * * If "flags" contains TCL_LEAVE_ERR_MSG, an error message is returned in |
| ︙ | ︙ | |||
4478 4479 4480 4481 4482 4483 4484 |
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
*/
goto done;
}
| | | | 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 |
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
*/
goto done;
}
cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
/*
* Populate information needed by the interpreter thread to fulfill the
* 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 *)ckrealloc(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;
|
| ︙ | ︙ | |||
4608 4609 4610 4611 4612 4613 4614 |
return TCL_OK;
}
static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
| | | | | 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 |
return TCL_OK;
}
static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
int 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
* needed, the exception handlers (as they should happen last).
|
| ︙ | ︙ | |||
4684 4685 4686 4687 4688 4689 4690 |
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/*
* Caller gave it to us.
*/
| | | 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 |
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) {
/*
|
| ︙ | ︙ | |||
4768 4769 4770 4771 4772 4773 4774 |
return TCL_OK;
}
static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
| | | | | 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 |
return TCL_OK;
}
static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
ClientData clientData = data[1];
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
const char *a[10];
int i = 0;
|
| ︙ | ︙ | |||
4958 4959 4960 4961 4962 4963 4964 |
static int
TEOV_RestoreVarFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 |
static int
TEOV_RestoreVarFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
((Interp *) interp)->varFramePtr = (CallFrame *)data[0];
return result;
}
static int
TEOV_Exception(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
5002 5003 5004 5005 5006 5007 5008 |
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
int cmdLen;
int objc = PTR2INT(data[0]);
| | | 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 |
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
int cmdLen;
int 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.
*/
|
| ︙ | ︙ | |||
5064 5065 5066 5067 5068 5069 5070 |
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
| | | 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 |
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
Tcl_ListObjGetElements(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.
*/
|
| ︙ | ︙ | |||
5125 5126 5127 5128 5129 5130 5131 |
TEOV_NotFoundCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 |
TEOV_NotFoundCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
Namespace *savedNsPtr = (Namespace *)data[2];
int i;
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
|
| ︙ | ︙ | |||
5206 5207 5208 5209 5210 5211 5212 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
| | | | | | 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
int 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) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
|
| ︙ | ︙ | |||
5405 5406 5407 5408 5409 5410 5411 |
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 refered to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
| | | 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 |
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 refered to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
* continuation lines in this "main script",
* and the character offsets are relative to
* the 'outerScript' as well.
*
* If outerScript == script, then this call is
* for the outer-most script/command. See
* Tcl_EvalEx() and TclEvalObjEx() for places
* generating arguments for which this is
|
| ︙ | ︙ | |||
5431 5432 5433 5434 5435 5436 5437 |
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
unsigned int 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. */
| | | | | | | 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 |
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
unsigned int 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));
int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
/* TIP #280 Structures for tracking of command
* locations. */
int *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
|
| ︙ | ︙ | |||
5572 5573 5574 5575 5576 5577 5578 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
| | | | | 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
expand = (int *)ckalloc(numWords * sizeof(int));
objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *));
lineSpace = (int *)ckalloc(numWords * sizeof(int));
}
expandRequested = 0;
objv = objvSpace;
lines = lineSpace;
iPtr->cmdFramePtr = eeFramePtr->nextPtr;
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
5660 5661 5662 5663 5664 5665 5666 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
| | | | 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
(Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
|
| ︙ | ︙ | |||
5982 5983 5984 5985 5986 5987 5988 |
hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
if (isNew) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
| | | | 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 |
hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
if (isNew) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
cfwPtr = (CFWord *)ckalloc(sizeof(CFWord));
cfwPtr->framePtr = cfPtr;
cfwPtr->word = i;
cfwPtr->refCount = 1;
Tcl_SetHashValue(hPtr, cfwPtr);
} else {
/*
* The word is already on the stack, its current location is not
* relevant. Just remember the reference to prevent early removal.
*/
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
cfwPtr->refCount++;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
6036 6037 6038 6039 6040 6041 6042 |
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
if (!hPtr) {
continue;
}
| | | 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 |
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
if (!hPtr) {
continue;
}
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
continue;
}
ckfree(cfwPtr);
Tcl_DeleteHashEntry(hPtr);
|
| ︙ | ︙ | |||
6088 6089 6090 6091 6092 6093 6094 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) {
return;
}
| | | 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) {
return;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
ePtr = &eclPtr->loc[cmd];
/*
* ePtr->nline is the number of words originally parsed.
*
* objc is the number of elements getting invoked.
*
|
| ︙ | ︙ | |||
6121 6122 6123 6124 6125 6126 6127 |
*
* 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) {
| | | | | | | 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 |
*
* 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 *)ckalloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
cfwPtr->pc = pc;
cfwPtr->word = word;
cfwPtr->nextPtr = lastPtr;
lastPtr = cfwPtr;
if (isNew) {
/*
* The word is not on the stack yet, remember the current
* location and initialize references.
*/
cfwPtr->prevPtr = NULL;
} else {
/*
* The object is already on the stack, however it may have
* a different location now (literal sharing may map
* multiple location to a single Tcl_Obj*. Save the old
* information in the new structure.
*/
cfwPtr->prevPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, cfwPtr);
}
} /* for */
cfPtr->litarg = lastPtr;
|
| ︙ | ︙ | |||
6190 6191 6192 6193 6194 6195 6196 |
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
| | | 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 |
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
Tcl_Panic("TclArgumentBC Enter/Release Mismatch");
}
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
|
| ︙ | ︙ | |||
6256 6257 6258 6259 6260 6261 6262 |
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
| | | | 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 |
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
*wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
return;
}
/*
* Check if the Tcl_Obj has location information as a bytecode literal, in
* that stack.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char *) (((ByteCode *)
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
*cfPtrPtr = cfwPtr->framePtr;
*wordPtr = cfwPtr->word;
return;
|
| ︙ | ︙ | |||
6458 6459 6460 6461 6462 6463 6464 | * This also preserves any associations between list elements and * location information for such elements. */ /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe | | | 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 | * This also preserves any associations between list elements and * location information for such elements. */ /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe * we always make a copy. The callback takes care of the refCounts for * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); |
| ︙ | ︙ | |||
6486 6487 6488 6489 6490 6491 6492 | * and TclInitCompileEnv), are special-cased to use the proper * line number directly instead of accessing the 'line' array. * * Note that we use (word==INTMIN) to signal that no command frame * should be pushed, as needed by alias and ensemble redirections. */ | | | 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 | * and TclInitCompileEnv), are special-cased to use the proper * line number directly instead of accessing the 'line' array. * * Note that we use (word==INTMIN) to signal that no command frame * should be pushed, as needed by alias and ensemble redirections. */ eoFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); eoFramePtr->nline = 0; eoFramePtr->line = NULL; eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); eoFramePtr->framePtr = iPtr->framePtr; |
| ︙ | ︙ | |||
6595 6596 6597 6598 6599 6600 6601 |
static int
TEOEx_ByteCodeCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 |
static int
TEOEx_ByteCodeCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallFrame *savedVarFramePtr = (CallFrame *)data[0];
Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
int allowExceptions = PTR2INT(data[2]);
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
|
| ︙ | ︙ | |||
6641 6642 6643 6644 6645 6646 6647 |
static int
TEOEx_ListCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 |
static int
TEOEx_ListCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
CmdFrame *eoFramePtr = (CmdFrame *)data[1];
Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
* Remove the cmdFrame
*/
if (eoFramePtr) {
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
|
| ︙ | ︙ | |||
7027 7028 7029 7030 7031 7032 7033 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
| | | 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
const char *cmdName; /* Name of the command from objv[0]. */
|
| ︙ | ︙ | |||
7050 7051 7052 7053 7054 7055 7056 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
| | | > | 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 7084 7085 7086 7087 7088 7089 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Avoid the exception-handling brain damage when numLevels == 0
*/
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
* That's the whole point of **hidden** commands. So tell the Eval core
* machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}
static int
NRPostInvoke(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *)interp;
iPtr->numLevels--;
return result;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
7334 7335 7336 7337 7338 7339 7340 | * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ | < | 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 |
* left in interp->result.
*
* Side effects:
* Depends on what was done by the command.
*
*----------------------------------------------------------------------
*/
int
Tcl_VarEval(
Tcl_Interp *interp,
...)
{
va_list argList;
int result;
|
| ︙ | ︙ | |||
7509 7510 7511 7512 7513 7514 7515 | * None. * *---------------------------------------------------------------------- */ static int ExprCeilFunc( | | | 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprCeilFunc(
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 code;
double d;
|
| ︙ | ︙ | |||
7549 7550 7551 7552 7553 7554 7555 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
| | | 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
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 code;
double d;
|
| ︙ | ︙ | |||
7589 7590 7591 7592 7593 7594 7595 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
| | | 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
ClientData ptr;
int type;
double d;
|
| ︙ | ︙ | |||
7695 7696 7697 7698 7699 7700 7701 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
| | | 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
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 code;
double d;
|
| ︙ | ︙ | |||
7863 7864 7865 7866 7867 7868 7869 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
| | | 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
ClientData ptr;
int type;
|
| ︙ | ︙ | |||
7962 7963 7964 7965 7966 7967 7968 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
| | | | 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 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
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 vector. */
{
int value;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
return TCL_OK;
}
static int
ExprDoubleFunc(
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 vector. */
{
double dResult;
|
| ︙ | ︙ | |||
8010 8011 8012 8013 8014 8015 8016 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
| | | 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
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 vector. */
{
double d;
int type;
|
| ︙ | ︙ | |||
8066 8067 8068 8069 8070 8071 8072 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
| | | | 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 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
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 vector. */
{
Tcl_WideInt wResult;
if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
/*
* Common implmentation of max() and min().
*/
static int
ExprMaxMinFunc(
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 vector. */
int op) /* Comparison direction */
{
Tcl_Obj *res;
|
| ︙ | ︙ | |||
8127 8128 8129 8130 8131 8132 8133 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
| | | | | | | 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 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
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 vector. */
{
return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT);
}
static int
ExprMinFunc(
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 vector. */
{
return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT);
}
static int
ExprRandFunc(
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 vector. */
{
Interp *iPtr = (Interp *) interp;
double dResult;
|
| ︙ | ︙ | |||
8180 8181 8182 8183 8184 8185 8186 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ | | | | 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 |
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Generate the random number using the linear congruential generator
* defined by the following recurrence:
|
| ︙ | ︙ | |||
8242 8243 8244 8245 8246 8247 8248 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
| | | 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8321 8322 8323 8324 8325 8326 8327 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
| | | | | | | 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 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
*/
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
* ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply clean
* up our state and call the real random number function. That function
* will always succeed.
*/
return ExprRandFunc(NULL, interp, 1, objv);
}
/*
*----------------------------------------------------------------------
*
* Double Classification Functions --
*
|
| ︙ | ︙ | |||
8443 8444 8445 8446 8447 8448 8449 |
/* 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.
*/
| | | | 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 |
/* 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;
|
| ︙ | ︙ | |||
8510 8511 8512 8513 8514 8515 8516 | #error "unknown or unexpected TCL_FPCLASSIFY_MODE" #endif /* TCL_FPCLASSIFY_MODE */ #endif /* !fpclassify */ } static int ExprIsFiniteFunc( | | | 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 |
#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
#endif /* TCL_FPCLASSIFY_MODE */
#endif /* !fpclassify */
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8541 8542 8543 8544 8545 8546 8547 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
| | | 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8571 8572 8573 8574 8575 8576 8577 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
| | | 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8601 8602 8603 8604 8605 8606 8607 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
| | | 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8631 8632 8633 8634 8635 8636 8637 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
| | | 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8661 8662 8663 8664 8665 8666 8667 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
| | | 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
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 */
{
double d;
ClientData ptr;
|
| ︙ | ︙ | |||
8702 8703 8704 8705 8706 8707 8708 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
| | | 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
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;
|
| ︙ | ︙ | |||
8787 8788 8789 8790 8791 8792 8793 |
tail--;
if (*tail == ':' && tail[-1] == ':') {
name = tail+1;
break;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 |
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", NULL);
}
#ifdef USE_DTRACE
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8811 8812 8813 8814 8815 8816 8817 | * The 'tcl-probe' DTrace probe is triggered (if it is enabled). * *---------------------------------------------------------------------- */ static int DTraceObjCmd( | | | | 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 |
* The 'tcl-probe' DTrace probe is triggered (if it is enabled).
*
*----------------------------------------------------------------------
*/
static int
DTraceObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (TCL_DTRACE_TCL_PROBE_ENABLED()) {
char *a[10];
int i = 0;
|
| ︙ | ︙ | |||
9195 9196 9197 9198 9199 9200 9201 | * updated so that its data[1] field contains the tailcall list. * *---------------------------------------------------------------------- */ int TclNRTailcallObjCmd( | | | 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 |
* updated so that its data[1] field contains the tailcall list.
*
*----------------------------------------------------------------------
*/
int
TclNRTailcallObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
if (objc < 1) {
|
| ︙ | ︙ | |||
9265 9266 9267 9268 9269 9270 9271 |
int
TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 |
int
TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
|
| ︙ | ︙ | |||
9300 9301 9302 9303 9304 9305 9306 |
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
int
TclNRReleaseValues(
ClientData data[],
| | > | 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 |
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
int
TclNRReleaseValues(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
while (i < 4) {
if (data[i]) {
Tcl_DecrRefCount((Tcl_Obj *) data[i]);
} else {
break;
}
i++;
|
| ︙ | ︙ | |||
9387 9388 9389 9390 9391 9392 9393 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
| | | 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 |
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_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
|
| ︙ | ︙ | |||
9441 9442 9443 9444 9445 9446 9447 |
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
| | | | 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 |
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]);
}
static int
RewindCoroutine(
CoroutineData *corPtr,
int result)
{
|
| ︙ | ︙ | |||
9468 9469 9470 9471 9472 9473 9474 |
return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
DeleteCoroutine(
ClientData clientData)
{
| | | | 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 |
return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
DeleteCoroutine(
ClientData clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
NRE_callback *rootPtr = TOP_CB(interp);
if (COR_IS_SUSPENDED(corPtr)) {
TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr);
}
}
static int
NRCoroutineCallerCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
* This is the last callback in the caller execEnv, right before switching
* to the coroutine's
*/
|
| ︙ | ︙ | |||
9510 9511 9512 9513 9514 9515 9516 |
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
| | | | 9511 9512 9513 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 |
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
if (cmdPtr->flags & CMD_DYING) {
/*
* The command was deleted while it was running: wind down the
* execEnv, this will do the complete cleanup. RewindCoroutine will
* restore both the caller's context and interp state.
*/
return RewindCoroutine(corPtr, result);
}
return result;
}
static int
NRCoroutineExitCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
* This runs at the bottom of the Coroutine's execEnv: it will be executed
* when the coroutine returns or is wound down, but not when it yields. It
* deletes the coroutine and restores the caller's environment.
*/
|
| ︙ | ︙ | |||
9592 9593 9594 9595 9596 9597 9598 |
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
| | | | 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 |
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
int type = PTR2INT(data[1]);
int numLevels, unused;
int *stackLevel = &unused;
if (!corPtr->stackLevel) {
/*
* -- Coroutine is suspended --
|
| ︙ | ︙ | |||
9671 9672 9673 9674 9675 9676 9677 |
*----------------------------------------------------------------------
*/
static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
| | | | 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 |
*----------------------------------------------------------------------
*/
static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
|
| ︙ | ︙ | |||
9697 9698 9699 9700 9701 9702 9703 | * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ static int CoroTypeObjCmd( | | | 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 |
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr;
CoroutineData *corPtr;
|
| ︙ | ︙ | |||
9728 9729 9730 9731 9732 9733 9734 |
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
| | | 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 |
}
/*
* 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", -1));
return TCL_OK;
}
/*
* Inactive coroutines are classified by the (effective) command used to
|
| ︙ | ︙ | |||
9782 9783 9784 9785 9786 9787 9788 |
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objPtr), NULL);
return NULL;
}
| | | | 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 |
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objPtr), NULL);
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
9832 9833 9834 9835 9836 9837 9838 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
| | | 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
int numLevels, unused;
|
| ︙ | ︙ | |||
9931 9932 9933 9934 9935 9936 9937 |
*----------------------------------------------------------------------
*/
static int
InjectHandler(
ClientData data[],
Tcl_Interp *interp,
| | | | | 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 |
*----------------------------------------------------------------------
*/
static int
InjectHandler(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
ClientData isProbe = data[3];
int objc;
Tcl_Obj **objv;
if (!isProbe) {
/*
|
| ︙ | ︙ | |||
9956 9957 9958 9959 9960 9961 9962 |
Tcl_ListObjAppendElement(NULL, listPtr,
Tcl_NewStringObj("yieldto", -1));
} else {
/*
* I don't think this is reachable...
*/
| | | 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 |
Tcl_ListObjAppendElement(NULL, listPtr,
Tcl_NewStringObj("yieldto", -1));
} else {
/*
* I don't think this is reachable...
*/
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewWideIntObj(nargs));
}
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
}
/*
* Call the user's script; we're in the right place.
*/
|
| ︙ | ︙ | |||
9979 9980 9981 9982 9983 9984 9985 |
static int
InjectHandlerPostCall(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 |
static int
InjectHandlerPostCall(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
ClientData isProbe = data[3];
int numLevels;
/*
* Delete the command words for what we just executed.
*/
|
| ︙ | ︙ | |||
10025 10026 10027 10028 10029 10030 10031 | * Implementation of [::tcl::unsupported::inject] command. * *---------------------------------------------------------------------- */ static int NRInjectObjCmd( | | | 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 |
* Implementation of [::tcl::unsupported::inject] command.
*
*----------------------------------------------------------------------
*/
static int
NRInjectObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
10075 10076 10077 10078 10079 10080 10081 |
int
TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 |
int
TclNRInterpCoroutine(
ClientData 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", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
10134 10135 10136 10137 10138 10139 10140 | * description of what this does. * *---------------------------------------------------------------------- */ int TclNRCoroutineObjCmd( | | | 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 |
* description of what this does.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr;
CoroutineData *corPtr;
const char *procName, *simpleName;
|
| ︙ | ︙ | |||
10175 10176 10177 10178 10179 10180 10181 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
| | | 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 10189 10190 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData));
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
|
| ︙ | ︙ | |||
10197 10198 10199 10200 10201 10202 10203 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
| | | 10198 10199 10200 10201 10202 10203 10204 10205 10206 10207 10208 10209 10210 10211 10212 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) {
int isNew;
Tcl_HashEntry *newPtr =
Tcl_CreateHashEntry(corPtr->lineLABCPtr,
|
| ︙ | ︙ | |||
10267 10268 10269 10270 10271 10272 10273 | /* * This is used in the [info] ensemble */ int TclInfoCoroutineCmd( | | | | 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 10285 10286 10287 10288 10289 10290 10291 10292 10293 10294 |
/*
* This is used in the [info] ensemble
*/
int
TclInfoCoroutineCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, namePtr);
Tcl_SetObjResult(interp, namePtr);
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
1 2 3 4 5 6 | /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * * Copyright © 1997 Sun Microsystems, Inc. * 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" #include "tclTomMath.h" |
| ︙ | ︙ | |||
263 264 265 266 267 268 269 270 271 272 273 |
* The following structure is the internal rep for a ByteArray object. Keeps
* track of how much memory has been used and how much has been allocated for
* the byte array to enable growing and shrinking of the ByteArray object with
* fewer mallocs.
*/
typedef struct ByteArray {
unsigned int used; /* The number of bytes used in the byte
* array. */
unsigned int allocated; /* The amount of space actually allocated
* minus 1 byte. */
| > > > | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
* The following structure is the internal rep for a ByteArray object. Keeps
* track of how much memory has been used and how much has been allocated for
* the byte array to enable growing and shrinking of the ByteArray object with
* fewer mallocs.
*/
typedef struct ByteArray {
unsigned int bad; /* Index of the character that is a nonbyte.
* If all characters are bytes, bad = used,
* though then we should never read it. */
unsigned int used; /* The number of bytes used in the byte
* array. */
unsigned int allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
(offsetof(ByteArray, bytes) + (len))
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length, /* Length of the array of bytes, which 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. */
{
| > < > > > > > > > > > > < > | 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 |
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length, /* Length of the array of bytes, which 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, length);
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. */
int length, /* Length of the array of bytes, which must be
* >= 0. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* Tcl_SetByteArrayObj --
*
* Modify an object to be a ByteArray object and to have the specified
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
}
byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->bad = length;
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, length);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
}
/*
*----------------------------------------------------------------------
*
* TclGetBytesFromObj --
*
* Attempt to extract the value from objPtr in the representation
* of a byte sequence. On success return the extracted byte sequence.
* On failures, return NULL and record error message and code in
* interp (if not NULL).
*
* Results:
* Pointer to array of bytes, or NULL. representing the ByteArray object.
* Writes number of bytes in array to *lengthPtr.
*
*----------------------------------------------------------------------
*/
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
SetByteArrayFromAny(NULL, objPtr);
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
if (interp) {
const char *nonbyte;
int ucs4;
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
baPtr = GET_BYTEARRAY(irPtr);
nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
TclUtfToUCS4(nonbyte, &ucs4);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected byte sequence but character %d "
"was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
}
return NULL;
}
}
baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetByteArrayFromObj --
*
* Attempt to get the array of bytes from the Tcl object. If the object
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
| | > | < | < < < < | | > > | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr;
unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr);
if (result) {
return result;
}
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
assert(irPtr != NULL);
baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return baPtr->bytes;
}
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
}
}
}
byteArrayPtr = GET_BYTEARRAY(irPtr);
if (newLength > byteArrayPtr->allocated) {
| | > > | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
}
}
}
byteArrayPtr = GET_BYTEARRAY(irPtr);
if (newLength > byteArrayPtr->allocated) {
byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength));
byteArrayPtr->allocated = newLength;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
byteArrayPtr->bad = newLength;
byteArrayPtr->used = newLength;
return byteArrayPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 | * A ByteArray object is stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( | | | < | | | > > | > > > > > | | > | | 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 |
* A ByteArray object is stored as the internal rep of objPtr.
*
*----------------------------------------------------------------------
*/
static int
SetByteArrayFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
size_t length, bad;
const char *src, *srcEnd;
unsigned char *dst;
Tcl_UniChar ch = 0;
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (TclHasIntRep(objPtr, &properByteArrayType)) {
return TCL_OK;
}
if (TclHasIntRep(objPtr, &tclByteArrayType)) {
return TCL_OK;
}
src = TclGetString(objPtr);
length = bad = objPtr->length;
srcEnd = src + length;
byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += TclUtfToUniChar(src, &ch);
if ((bad == length) && (ch > 255)) {
bad = dst - byteArrayPtr->bytes;
}
*dst++ = UCHAR(ch);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
byteArrayPtr->allocated = length;
byteArrayPtr->used = dst - byteArrayPtr->bytes;
if (bad == length) {
byteArrayPtr->bad = byteArrayPtr->used;
Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
} else {
byteArrayPtr->bad = bad;
Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeByteArrayInternalRep --
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 |
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
| | > | > | 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 |
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir);
}
static void
DupProperByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = length;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
if (needed <= INT_MAX/2) {
/*
* Try to allocate double the total space that is needed.
*/
attempt = 2 * needed;
| | | | > | 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 |
if (needed <= INT_MAX/2) {
/*
* Try to allocate double the total space that is needed.
*/
attempt = 2 * needed;
ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Try to allocate double the increment that is needed (plus).
*/
unsigned int limit = INT_MAX - needed;
unsigned int extra = length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Last chance: Try to allocate exactly what is needed.
*/
attempt = needed;
ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length);
}
byteArrayPtr->used += length;
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
}
/*
*----------------------------------------------------------------------
*
* TclInitBinaryCmd --
*
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 | * See the user documentation. * *---------------------------------------------------------------------- */ static int BinaryFormatCmd( | | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
BinaryFormatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
* Initialized to avoid compiler warning. */
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 |
}
/*
* Prepare the result object by preallocating the caclulated number of
* bytes and filling with nulls.
*/
| | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
}
/*
* Prepare the result object by preallocating the caclulated number of
* bytes and filling with nulls.
*/
TclNewObj(resultPtr);
buffer = Tcl_SetByteArrayLength(resultPtr, length);
memset(buffer, 0, length);
/*
* Pack the data into the result object. Note that we can skip the error
* checking during this pass, since we have already parsed the string
* once.
|
| ︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | | 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xF);
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 |
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= ((c << 4) & 0xF0);
if (offset % 2) {
*cursor++ = UCHAR(value & 0xFF);
value = 0;
}
}
}
if (offset % 2) {
if (cmd == 'H') {
value <<= 4;
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 | * See the user documentation. * *---------------------------------------------------------------------- */ int BinaryScanCmd( | | | < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
BinaryScanCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
* Initialized to avoid compiler warning. */
char cmd; /* Current format character. */
int count; /* Count associated with current format
* character. */
int flags; /* Format field flags */
const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
int offset, size, length, i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"value formatString ?varName ...?");
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
str = format;
flags = 0;
if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
goto done;
}
switch (cmd) {
case 'a':
| > | | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 |
str = format;
flags = 0;
if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
goto done;
}
switch (cmd) {
case 'a':
case 'A':
case 'C': {
unsigned char *src;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 | } } src = buffer + offset; size = count; /* | > | | > > > > > > > | 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 |
}
}
src = buffer + offset;
size = count;
/*
* Apply C string semantics or trim trailing
* nulls and spaces, if necessary.
*/
if (cmd == 'C') {
for (i = 0; i < size; i++) {
if (src[i] == '\0') {
size = i;
break;
}
}
} else if (cmd == 'A') {
while (size > 0) {
if (src[size - 1] != '\0' && src[size - 1] != ' ') {
break;
}
size--;
}
}
|
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 |
count = 1;
}
if (count > (length - offset) * 8) {
goto done;
}
}
src = buffer + offset;
| | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
count = 1;
}
if (count > (length - offset) * 8) {
goto done;
}
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
if (i % 8) {
value >>= 1;
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 |
count = 1;
}
if (count > (length - offset)*2) {
goto done;
}
}
src = buffer + offset;
| | | | | 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 |
count = 1;
}
if (count > (length - offset)*2) {
goto done;
}
}
src = buffer + offset;
TclNewObj(valuePtr);
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[value & 0xF];
}
} else {
for (i = 0; i < count; i++) {
if (i % 2) {
value <<= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xF];
}
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
|
| ︙ | ︙ | |||
1651 1652 1653 1654 1655 1656 1657 |
} else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
if ((length - offset) < (count * size)) {
goto done;
}
| | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
} else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
if ((length - offset) < (count * size)) {
goto done;
}
TclNewObj(valuePtr);
src = buffer + offset;
for (i = 0; i < count; i++) {
elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
offset += count * size;
|
| ︙ | ︙ | |||
1942 1943 1944 1945 1946 1947 1948 |
int type) /* What type of thing are we copying? */
{
switch (NeedReversing(type)) {
case 0:
memcpy(to, from, length);
break;
case 1: {
| | | | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 |
int type) /* What type of thing are we copying? */
{
switch (NeedReversing(type)) {
case 0:
memcpy(to, from, length);
break;
case 1: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
switch (length) {
case 4:
toPtr[0] = fromPtr[3];
toPtr[1] = fromPtr[2];
toPtr[2] = fromPtr[1];
toPtr[3] = fromPtr[0];
|
| ︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 |
toPtr[6] = fromPtr[1];
toPtr[7] = fromPtr[0];
break;
}
break;
}
case 2: {
| | | | | | 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 |
toPtr[6] = fromPtr[1];
toPtr[7] = fromPtr[0];
break;
}
break;
}
case 2: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[4];
toPtr[1] = fromPtr[5];
toPtr[2] = fromPtr[6];
toPtr[3] = fromPtr[7];
toPtr[4] = fromPtr[0];
toPtr[5] = fromPtr[1];
toPtr[6] = fromPtr[2];
toPtr[7] = fromPtr[3];
break;
}
case 3: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[3];
toPtr[1] = fromPtr[2];
toPtr[2] = fromPtr[1];
toPtr[3] = fromPtr[0];
toPtr[4] = fromPtr[7];
toPtr[5] = fromPtr[6];
|
| ︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 |
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
| | | > | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 |
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
Tcl_Obj *objPtr;
TclNewIntObj(objPtr, value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
}
/*
* We've overflowed the cache! Someone's parsing a LOT of varied
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
| | | 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 |
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
Tcl_Obj *value = (Tcl_Obj *)Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
}
hEntry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(numberCachePtr);
|
| ︙ | ︙ | |||
2459 2460 2461 2462 2463 2464 2465 | * None * *---------------------------------------------------------------------- */ static int BinaryEncodeHex( | | | | | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryEncodeHex(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data = NULL;
unsigned char *cursor = NULL;
int offset = 0, count = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "data");
return TCL_ERROR;
}
TclNewObj(resultObj);
data = Tcl_GetByteArrayFromObj(objv[1], &count);
cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
for (offset = 0; offset < count; ++offset) {
*cursor++ = HexDigits[(data[offset] >> 4) & 0x0F];
*cursor++ = HexDigits[data[offset] & 0x0F];
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2503 2504 2505 2506 2507 2508 2509 | * None * *---------------------------------------------------------------------- */ static int BinaryDecodeHex( | | | > > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecodeHex(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, size, pure = 1, count = 0, cut = 0, strict = 0;
int ucs4;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(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;
for (i = 0 ; i < 2 ; i++) {
if (data >= dataend) {
|
| ︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | > > > > > | | > < < < | | < < < | 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 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= c & 0xF;
}
if (i < 2) {
cut++;
}
*cursor++ = UCHAR(value);
value = 0;
}
if (cut > size) {
cut = size;
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
badChar:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hexadecimal digit \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryEncode64 --
*
* This procedure implements the "binary encode base64" Tcl command.
*
* Results:
* The base64 encoded value prescribed by the input arguments.
*
*----------------------------------------------------------------------
*/
#define OUTPUT(c) \
do { \
*cursor++ = (c); \
|
| ︙ | ︙ | |||
2622 2623 2624 2625 2626 2627 2628 |
if (cursor > limit) { \
Tcl_Panic("limit hit"); \
} \
} while (0)
static int
BinaryEncode64(
| | | | | 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 |
if (cursor > limit) { \
Tcl_Panic("limit hit"); \
} \
} while (0)
static int
BinaryEncode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *limit;
int maxlen = 0;
const char *wrapchar = "\n";
int wrapcharlen = 1;
int offset, i, index, size, outindex = 0, count = 0, purewrap = 1;
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-maxlen len? ?-wrapchar char? data");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 | "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: | > | | | > > > | > | > > | > > > > > > > > | > | | | 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 |
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)TclGetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
TclNewObj(resultObj);
data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count);
if (count > 0) {
unsigned char *cursor = NULL;
size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
if (maxlen > 0 && size > maxlen) {
int adjusted = size + (wrapcharlen * (size / maxlen));
if (size % maxlen == 0) {
adjusted -= wrapcharlen;
}
size = adjusted;
if (purewrap == 0) {
/* Wrapchar is (possibly) non-byte, so build result as
* general string, not bytearray */
Tcl_SetObjLength(resultObj, size);
cursor = (unsigned char *) TclGetString(resultObj);
}
}
if (cursor == NULL) {
cursor = Tcl_SetByteArrayLength(resultObj, size);
}
limit = cursor + size;
for (offset = 0; offset < count; offset += 3) {
unsigned char d[3] = {0, 0, 0};
for (i = 0; i < 3 && offset + i < count; ++i) {
d[i] = data[offset + i];
}
OUTPUT(B64Digits[d[0] >> 2]);
OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
if (offset + 1 < count) {
OUTPUT(B64Digits[((d[1] & 0x0F) << 2) | (d[2] >> 6)]);
} else {
OUTPUT(B64Digits[64]);
}
if (offset+2 < count) {
OUTPUT(B64Digits[d[2] & 0x3F]);
} else {
OUTPUT(B64Digits[64]);
}
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
|
| ︙ | ︙ | |||
2728 2729 2730 2731 2732 2733 2734 | * None * *---------------------------------------------------------------------- */ static int BinaryEncodeUu( | | | | 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryEncodeUu(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
int offset, count, rawLength, n, i, j, bits, index;
int lineLength = 61;
const unsigned char SingleNewline[] = { UCHAR('\n') };
const unsigned char *wrapchar = SingleNewline;
int wrapcharlen = sizeof(SingleNewline);
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
2759 2760 2761 2762 2763 2764 2765 |
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
| | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&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", 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;
int numBytes = wrapcharlen;
while (numBytes) {
switch (*p) {
case '\t':
case '\v':
case '\f':
case '\r':
p++; numBytes--;
continue;
case '\n':
numBytes--;
break;
default:
badwrap:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invalid wrapchar; will defeat decoding",
-1));
Tcl_SetErrorCode(interp, "TCL", "BINARY",
"ENCODE", "WRAPCHAR", NULL);
return TCL_ERROR;
}
}
if (numBytes) {
goto badwrap;
}
}
break;
}
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
*/
TclNewObj(resultObj);
offset = 0;
data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count);
rawLength = (lineLength - 1) * 3 / 4;
start = cursor = Tcl_SetByteArrayLength(resultObj,
(lineLength + wrapcharlen) *
((count + (rawLength - 1)) / rawLength));
n = bits = 0;
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i = 0 ; i < lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
| | | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 |
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i = 0 ; i < lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
*cursor++ = UueDigits[(n >> (bits - 6)) & 0x3F];
}
}
if (bits > 0) {
n <<= 8;
*cursor++ = UueDigits[(n >> (bits + 2)) & 0x3F];
bits = 0;
}
for (j = 0 ; j < wrapcharlen ; ++j) {
*cursor++ = wrapchar[j];
}
}
|
| ︙ | ︙ | |||
2845 2846 2847 2848 2849 2850 2851 | * None * *---------------------------------------------------------------------- */ static int BinaryDecodeUu( | | | > > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecodeUu(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
int i, index, size, pure = 1, count = 0, strict = 0, lineLen;
unsigned char c;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(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;
/*
* The decoding loop. First, we get the length of line (strictly, the
|
| ︙ | ︙ | |||
2901 2902 2903 2904 2905 2906 2907 |
if (c < 32 || c > 96) {
if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
continue;
}
| | | 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 |
if (c < 32 || c > 96) {
if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
continue;
}
lineLen = (c - 32) & 0x3F;
}
/*
* Now we read a four-character grouping.
*/
for (i = 0 ; i < 4 ; i++) {
|
| ︙ | ︙ | |||
2930 2931 2932 2933 2934 2935 2936 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
| | | | | | | | 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
*cursor++ = (((d[0] - 0x20) & 0x3F) << 2)
| (((d[1] - 0x20) & 0x3F) >> 4);
if (--lineLen > 0) {
*cursor++ = (((d[1] - 0x20) & 0x3F) << 4)
| (((d[2] - 0x20) & 0x3F) >> 2);
if (--lineLen > 0) {
*cursor++ = (((d[2] - 0x20) & 0x3F) << 6)
| (((d[3] - 0x20) & 0x3F));
lineLen--;
}
}
}
/*
* If we've reached the end of the line, skip until we process a
|
| ︙ | ︙ | |||
2982 2983 2984 2985 2986 2987 2988 2989 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| > > > > > | | | 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3008 3009 3010 3011 3012 3013 3014 | * None * *---------------------------------------------------------------------- */ static int BinaryDecode64( | | | > > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int pure = 1, strict = 0;
int i, index, size, cut = 0, count = 0;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(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;
/*
|
| ︙ | ︙ | |||
3090 3091 3092 3093 3094 3095 3096 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
| | | | | | | | | | | < < < < < > > > > > > > > > > > | | > | 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 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
} else if (!strict) {
i--;
} else {
goto bad64;
}
} else if (c >= 'A' && c <= 'Z') {
value = (value << 6) | ((c - 'A') & 0x3F);
} else if (c >= 'a' && c <= 'z') {
value = (value << 6) | ((c - 'a' + 26) & 0x3F);
} else if (c >= '0' && c <= '9') {
value = (value << 6) | ((c - '0' + 52) & 0x3F);
} else if (c == '+') {
value = (value << 6) | 0x3E;
} else if (c == '/') {
value = (value << 6) | 0x3F;
} else if (c == '=' && (!strict || i > 1)) {
/*
* "=" and "a=" is rather bad64 error case in strict mode.
*/
value <<= 6;
if (i) {
cut++;
}
} else if (strict) {
goto bad64;
} else {
i--;
}
}
*cursor++ = UCHAR((value >> 16) & 0xFF);
*cursor++ = UCHAR((value >> 8) & 0xFF);
*cursor++ = UCHAR(value & 0xFF);
/*
* Since = is only valid within the final block, if it was encountered
* but there are still more input characters, confirm that strict mode
* is off and all subsequent characters are whitespace.
*/
if (cut && data < dataend) {
if (strict) {
goto bad64;
}
}
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
bad64:
if (pure) {
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 */
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid base64 character \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCkalloc.c.
1 2 3 4 5 6 7 | /* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging * problems involving overwritten, double freeing memory and loss of * memory. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging * problems involving overwritten, double freeing memory and loss of * memory. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * 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. * * This code contributed by Karl Lehenbauer and Mark Diekhans */ |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
| | | | 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 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "low guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
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 %d is 0x%x \t%c\n", (int)idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
total_frees++;
current_malloc_packets--;
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
| | | | 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 |
total_frees++;
current_malloc_packets--;
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
TclpFree(memp->tagPtr);
}
}
/*
* Delink from allocated list
*/
if (memp->flink != NULL) {
memp->flink->blink = memp->blink;
}
if (memp->blink != NULL) {
memp->blink->flink = memp->flink;
}
if (allocHead == memp) {
allocHead = memp->flink;
}
TclpFree(memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*--------------------------------------------------------------------
*
* Tcl_DbCkrealloc - debugging ckrealloc
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 | * memory validate on|off * * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ | < | | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
* memory validate on|off
*
* Results:
* Standard TCL results.
*
*----------------------------------------------------------------------
*/
static int
MemoryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
}
if (strcmp(TclGetString(objv[1]),"tag") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
| | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
}
if (strcmp(TclGetString(objv[1]),"tag") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree(curTagPtr);
}
len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
|
| ︙ | ︙ | |||
983 984 985 986 987 988 989 | */ static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int CheckmemCmd( | | | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
*/
static int CheckmemCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int
CheckmemCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter for evaluation. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
strcpy(tclMemDumpFileName, TclGetString(objv[1]));
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 |
*----------------------------------------------------------------------
*/
char *
Tcl_Alloc(
unsigned int size)
{
| | < < | 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 |
*----------------------------------------------------------------------
*/
char *
Tcl_Alloc(
unsigned int size)
{
char *result = (char *)TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so that NULL
* isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning
* NULL, so we have to check that the NULL we get is not in response to
* alloc(0).
*
|
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 |
char *
Tcl_DbCkalloc(
unsigned int size,
const char *file,
int line)
{
| | < < | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
char *
Tcl_DbCkalloc(
unsigned int size,
const char *file,
int line)
{
char *result = (char *)TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
return result;
}
|
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 |
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptAlloc(
unsigned int size)
{
| < < | < | | < < < < | < | < < | < < | 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 |
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptAlloc(
unsigned int size)
{
return (char *)TclpAlloc(size);
}
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return (char *)TclpAlloc(size);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Realloc --
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Realloc(
char *ptr,
unsigned int size)
{
char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %u bytes", size);
}
return result;
}
char *
Tcl_DbCkrealloc(
char *ptr,
unsigned int size,
const char *file,
int line)
{
char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
}
return result;
}
|
| ︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 |
*/
char *
Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
| < < | < | | < < < < | < | 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 |
*/
char *
Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
return (char *)TclpRealloc(ptr, size);
}
char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return (char *)TclpRealloc(ptr, size);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Free --
*
|
| ︙ | ︙ | |||
1223 1224 1225 1226 1227 1228 1229 |
{
TclpFree(ptr);
}
void
Tcl_DbCkfree(
char *ptr,
| | | < < < | < | < | | < < | | < < | 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 |
{
TclpFree(ptr);
}
void
Tcl_DbCkfree(
char *ptr,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
TclpFree(ptr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
*
* Dummy initialization for memory command, which is only available if
* TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitMemory(
TCL_UNUSED(Tcl_Interp *) /*interp*/)
{
}
int
Tcl_DumpActiveMemory(
TCL_UNUSED(const char *) /*fileName*/)
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
}
int
TclDumpMemoryInfo(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*flags*/)
{
return 1;
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
| | | | 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 |
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree(curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if defined(USE_TCLALLOC) && USE_TCLALLOC
TclFinalizeAllocSubsystem();
#endif
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclClock.c.
1 2 3 4 5 6 7 | /* * 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. * | | | | | 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" |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
* 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_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
| | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
* 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_Obj *tzName; /* Time zone name */
int 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 */
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
| | | | | 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 |
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* 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 *)ckalloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = (Tcl_Obj **)ckalloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
data->literals[i] = Tcl_NewStringObj(literals[i], -1);
Tcl_IncrRefCount(data->literals[i]);
}
/*
* Install the commands.
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
static int
ClockConvertlocaltoutcObjCmd(
ClientData clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
| | | | | 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 |
static int
ClockConvertlocaltoutcObjCmd(
ClientData clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
int status;
/*
* Check params and convert time.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
return TCL_ERROR;
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, lit[LIT_LOCALSECONDS],
&secondsObj)!= TCL_OK) {
return TCL_ERROR;
}
if (secondsObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
"found in dictionary", -1));
return TCL_ERROR;
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
| | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
ClientData 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;
| | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
ClientData 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;
/*
* Check params.
*/
if (objc != 4) {
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasIntRep(objv[1], &tclBignumType)) {
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasIntRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/*
* Convert UTC time to local.
*/
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
*/
GetGregorianEraYearDay(&fields, changeover);
GetMonthDay(&fields);
GetYearWeekDay(&fields, changeover);
dict = Tcl_NewDictObj();
| | | | | | | | | | | | | | | | | 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 |
*/
GetGregorianEraYearDay(&fields, changeover);
GetMonthDay(&fields);
GetYearWeekDay(&fields, changeover);
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);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET],
Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN],
Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, lit[LIT_ERA],
lit[fields.isBce ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR],
Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR],
Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH],
Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH],
Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR],
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;
}
/*
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 |
ClientData 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;
| | | | | | | | | | | 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 |
ClientData 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;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFMONTH],
&fields.dayOfMonth) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearMonthDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
ClientData 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;
| | | | | | | | | | | 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 |
ClientData 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;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601YEAR],
&fields.iso8601Year) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601WEEK],
&fields.iso8601Week) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFWEEK],
&fields.dayOfWeek) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearWeekDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 |
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
| | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
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.
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 |
/*
* 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;
GetGregorianEraYearDay(&temp, changeover);
| | | | 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 |
/*
* 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;
GetGregorianEraYearDay(&temp, changeover);
if (temp.isBce) {
temp.iso8601Year = temp.year - 1;
} else {
temp.iso8601Year = temp.year + 1;
}
temp.iso8601Week = 1;
temp.dayOfWeek = 1;
GetJulianDayFromEraYearWeekDay(&temp, changeover);
/*
* temp.julianDay is now the start of an ISO8601 year, either the one
* corresponding to the given date, or the one after. If we guessed high,
* move one year earlier
*/
if (fields->julianDay < temp.julianDay) {
if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
}
GetJulianDayFromEraYearWeekDay(&temp, changeover);
}
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
year += n;
/*
* store era/year/day back into fields.
*/
if (year <= 0) {
| | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 |
year += n;
/*
* store era/year/day back into fields.
*/
if (year <= 0) {
fields->isBce = 1;
fields->year = 1 - year;
} else {
fields->isBce = 0;
fields->year = year;
}
fields->dayOfYear = day + 1;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
* given year */
TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
| | | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 |
* given year */
TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
firstWeek.dayOfMonth = 4;
GetJulianDayFromEraYearMonthDay(&firstWeek, changeover);
/*
* Find Monday of week 1.
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 |
static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
| | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
}
/*
* Reduce month modulo 12.
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
| | | | 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 |
static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
int year = fields->year;
| | | 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 |
static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
int 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) {
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 | * the value of the variable if the variable does exist, * *---------------------------------------------------------------------- */ int ClockGetenvObjCmd( | | < | 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
* the value of the variable if the variable does exist,
*
*----------------------------------------------------------------------
*/
int
ClockGetenvObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
const char *varName;
const char *varValue;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
varName = TclGetString(objv[1]);
varValue = getenv(varName);
|
| ︙ | ︙ | |||
1689 1690 1691 1692 1693 1694 1695 |
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
| | | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 |
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm *tmPtr = (struct tm *)Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
struct tm *sysTmPtr;
Tcl_MutexLock(&clockMutex);
sysTmPtr = localtime(timePtr);
|
| ︙ | ︙ | |||
1727 1728 1729 1730 1731 1732 1733 | * documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockClicksObjCmd( | | < | 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 |
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockClicksObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
static const char *const clicksSwitches[] = {
"-milliseconds", "-microseconds", NULL
};
enum ClicksSwitch {
CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
};
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
switch (objc) {
case 1:
break;
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
|
| ︙ | ︙ | |||
1798 1799 1800 1801 1802 1803 1804 | * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockMillisecondsObjCmd( | | < | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockMillisecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
|
| ︙ | ︙ | |||
1836 1837 1838 1839 1840 1841 1842 | * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockMicrosecondsObjCmd( | | < | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockMicrosecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1875 1876 1877 1878 1879 1880 1881 |
static int
ClockParseformatargsObjCmd(
ClientData clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
| | | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
static int
ClockParseformatargsObjCmd(
ClientData 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;
Tcl_Obj **litPtr = dataPtr->literals;
Tcl_Obj *results[3]; /* Format, locale and timezone */
#define formatObj results[0]
#define localeObj results[1]
#define timezoneObj results[2]
int gmtFlag = 0;
static const char *const options[] = { /* Command line options expected */
|
| ︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 | * documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockSecondsObjCmd( | | < | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 |
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockSecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
|
| ︙ | ︙ | |||
2025 2026 2027 2028 2029 2030 2031 |
*
*----------------------------------------------------------------------
*/
static void
TzsetIfNecessary(void)
{
| | | | 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 |
*
*----------------------------------------------------------------------
*/
static void
TzsetIfNecessary(void)
{
static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by
* clockMutex. */
const char *tzIsNow; /* Current value of TZ */
Tcl_MutexLock(&clockMutex);
tzIsNow = getenv("TZ");
if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1)
|| strcmp(tzIsNow, tzWas) != 0)) {
tzset();
if (tzWas != NULL && tzWas != INT2PTR(-1)) {
ckfree(tzWas);
}
tzWas = (char *)ckalloc(strlen(tzIsNow) + 1);
strcpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
if (tzWas != INT2PTR(-1)) ckfree(tzWas);
tzWas = NULL;
}
Tcl_MutexUnlock(&clockMutex);
|
| ︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 |
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
ClientData clientData) /* Opaque pointer to the client data */
{
| | | 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 |
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
ClientData 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]);
}
ckfree(data->literals);
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
1 2 3 4 5 6 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters A to H. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters A to H. * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef _WIN32 |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); | | < < | < < | < < | < < | < < | | 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 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); static Tcl_ObjCmdProc EncodingConvertfromObjCmd; static Tcl_ObjCmdProc EncodingConverttoObjCmd; static Tcl_ObjCmdProc EncodingDirsObjCmd; static Tcl_ObjCmdProc EncodingNamesObjCmd; static Tcl_ObjCmdProc EncodingSystemObjCmd; static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); 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; |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_BreakObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 | < | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
int
Tcl_CaseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i;
int body, result, caseObjc;
const char *stringPtr, *arg;
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
/*
* Check for special case of single pattern (no list) with no
* backslash sequences.
*/
pat = TclGetString(caseObjv[i]);
for (p = pat; *p != '\0'; p++) {
| | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
/*
* Check for special case of single pattern (no list) with no
* backslash sequences.
*/
pat = TclGetString(caseObjv[i]);
for (p = pat; *p != '\0'; p++) {
if (TclIsSpaceProcM(*p) || (*p == '\\')) {
break;
}
}
if (*p == '\0') {
if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
body = i + 1;
}
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CatchObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 |
CatchObjCmdCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
CatchObjCmdCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
int rewind = iPtr->execEnvPtr->rewind;
/*
* We disable catch in interpreters where the limit has been exceeded.
*/
if (rewind || Tcl_LimitExceeded(interp)) {
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CdObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dir;
int result;
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConcatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc >= 2) {
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
}
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ContinueObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConvertfromObjCmd( | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConvertfromObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConverttoObjCmd( | | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConverttoObjCmd(
TCL_UNUSED(ClientData),
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 */
|
| ︙ | ︙ | |||
678 679 680 681 682 683 684 | * Can set the encoding search path. * *---------------------------------------------------------------------- */ int EncodingDirsObjCmd( | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
* Can set the encoding search path.
*
*----------------------------------------------------------------------
*/
int
EncodingDirsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dirListObj;
if (objc > 2) {
|
| ︙ | ︙ | |||
721 722 723 724 725 726 727 | * Results: * Returns a standard Tcl result * *----------------------------------------------------------------------------- */ int | | > | | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
* Results:
* Returns a standard Tcl result
*
*-----------------------------------------------------------------------------
*/
int
EncodingNamesObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetEncodingNames(interp);
return TCL_OK;
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * Side effects: * May change the system encoding. * *----------------------------------------------------------------------------- */ int | | > | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
* Side effects:
* May change the system encoding.
*
*-----------------------------------------------------------------------------
*/
int
EncodingSystemObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp,
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ErrorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options, *optName;
if ((objc < 2) || (objc > 4)) {
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
EvalCmdErrMsg(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)));
}
return result;
}
int
Tcl_EvalObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
|
| ︙ | ︙ | |||
919 920 921 922 923 924 925 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | < | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
return TCL_ERROR;
}
if (objc == 1) {
value = 0;
} else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Exit((int)value);
return TCL_OK; /* Better not ever reach this! */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExprObjCmd --
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExprObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr, *objPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
static int
ExprCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
static int
ExprCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultPtr = (Tcl_Obj *)data[0];
Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
if (objPtr != NULL) {
Tcl_DecrRefCount(objPtr);
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 | * May update the access time on the file, if requested by the user. * *---------------------------------------------------------------------- */ static int FileAttrAccessTimeCmd( | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
* May update the access time on the file, if requested by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrAccessTimeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | * user. * *---------------------------------------------------------------------- */ static int FileAttrModifyTimeCmd( | | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
* user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrModifyTimeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
|
| ︙ | ︙ | |||
1278 1279 1280 1281 1282 1283 1284 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrLinkStatCmd( | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrLinkStatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrStatCmd( | | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrStatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | * None. * *---------------------------------------------------------------------- */ static int FileAttrTypeCmd( | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 | * None. * *---------------------------------------------------------------------- */ static int FileAttrSizeCmd( | | | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsDirectoryCmd( | | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsDirectoryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExecutableCmd( | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExecutableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExistingCmd( | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExistingCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsFileCmd( | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsFileCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1563 1564 1565 1566 1567 1568 1569 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsOwnedCmd( | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsOwnedCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
#ifdef __CYGWIN__
#define geteuid() (short)(geteuid)()
#endif
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsReadableCmd( | | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsReadableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsWritableCmd( | | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsWritableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1672 1673 1674 1675 1676 1677 1678 | * None. * *---------------------------------------------------------------------- */ static int PathDirNameCmd( | | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathDirNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 | * None. * *---------------------------------------------------------------------- */ static int PathExtensionCmd( | | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathExtensionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 | * None. * *---------------------------------------------------------------------- */ static int PathRootNameCmd( | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathRootNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1789 1790 1791 1792 1793 1794 1795 | * None. * *---------------------------------------------------------------------- */ static int PathTailCmd( | | | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTailCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 | * None. * *---------------------------------------------------------------------- */ static int PathFilesystemCmd( | | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathFilesystemCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fsInfo;
if (objc != 2) {
|
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 | * None. * *---------------------------------------------------------------------- */ static int PathJoinCmd( | | | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathJoinCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 | * None. * *---------------------------------------------------------------------- */ static int PathNativeNameCmd( | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNativeNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_DString ds;
if (objc != 2) {
|
| ︙ | ︙ | |||
1938 1939 1940 1941 1942 1943 1944 | * None. * *---------------------------------------------------------------------- */ static int PathNormalizeCmd( | | | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNormalizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fileName;
if (objc != 2) {
|
| ︙ | ︙ | |||
1976 1977 1978 1979 1980 1981 1982 | * None. * *---------------------------------------------------------------------- */ static int PathSplitCmd( | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathSplitCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *res;
if (objc != 2) {
|
| ︙ | ︙ | |||
2019 2020 2021 2022 2023 2024 2025 | * None. * *---------------------------------------------------------------------- */ static int PathTypeCmd( | | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *typeName;
if (objc != 2) {
|
| ︙ | ︙ | |||
2067 2068 2069 2070 2071 2072 2073 | * None. * *---------------------------------------------------------------------- */ static int FilesystemSeparatorCmd( | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemSeparatorCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name?");
return TCL_ERROR;
}
if (objc == 1) {
const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
|
| ︙ | ︙ | |||
2122 2123 2124 2125 2126 2127 2128 | * None. * *---------------------------------------------------------------------- */ static int FilesystemVolumesCmd( | | | 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemVolumesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 | * | | * ForPostNextCallback | * |____________________| * *---------------------------------------------------------------------- */ | < | | | | 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 |
* | |
* ForPostNextCallback |
* |____________________|
*
*----------------------------------------------------------------------
*/
int
Tcl_ForObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr;
|
| ︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 |
static int
ForSetupCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 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 |
static int
ForSetupCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return TCL_OK;
}
int
TclNRForIterCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj;
switch (result) {
case TCL_OK:
case TCL_CONTINUE:
/*
* We need to reset the result before evaluating the expression.
|
| ︙ | ︙ | |||
2483 2484 2485 2486 2487 2488 2489 |
static int
ForCondCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 |
static int
ForCondCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj = (Tcl_Obj *)data[1];
int value;
if (result != TCL_OK) {
Tcl_DecrRefCount(boolObj);
TclSmallFreeEx(interp, iterPtr);
return result;
} else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
|
| ︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 |
static int
ForNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 |
static int
ForNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *next = iterPtr->next;
if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
TclNRAddCallback(interp, ForPostNextCallback, iterPtr, NULL, NULL,
NULL);
/*
|
| ︙ | ︙ | |||
2545 2546 2547 2548 2549 2550 2551 |
static int
ForPostNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 |
static int
ForPostNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if ((result != TCL_BREAK) && (result != TCL_OK)) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
TclSmallFreeEx(interp, iterPtr);
}
return result;
|
| ︙ | ︙ | |||
2575 2576 2577 2578 2579 2580 2581 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForeachObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv);
}
int
Tcl_LmapObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
static int
EachloopCmd(
Tcl_Interp *interp, /* Our context for variables and script
* evaluation. */
int collect, /* Select collecting or accumulating mode
* (TCL_EACH_*) */
int objc, /* The arguments being passed in... */
Tcl_Obj *const objv[])
|
| ︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 |
* statePtr->argvList[i].
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
| | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 |
* statePtr->argvList[i].
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
statePtr = (struct ForeachState *)TclStackAlloc(interp,
sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
memset(statePtr, 0,
sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
statePtr->argvList = statePtr->varvList + numLists;
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 |
static int
ForeachLoopStep(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 |
static int
ForeachLoopStep(
ClientData data[],
Tcl_Interp *interp,
int result)
{
struct ForeachState *statePtr = (struct ForeachState *)data[0];
/*
* Process the result code from this run of the [foreach] body. Note that
* this switch uses fallthroughs in several places. Maintainer aware!
*/
switch (result) {
|
| ︙ | ︙ | |||
2893 2894 2895 2896 2897 2898 2899 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FormatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr; /* Where result is stored finally. */
if (objc < 2) {
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
1 2 3 4 5 6 7 8 | /* * tclCmdIL.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters I through L. It * contains only commands in the generic core (i.e., those that don't * depend much upon UNIX facilities). * | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclCmdIL.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters I through L. It * contains only commands in the generic core (i.e., those that don't * depend much upon UNIX facilities). * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1993-1997 Lucent Technologies. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" |
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; | | < | < | < | < | < | < | < | < | < | < | < | < | < | < < | < | < | < | < | < | < | 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 | /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; static Tcl_ObjCmdProc InfoArgsCmd; static Tcl_ObjCmdProc InfoBodyCmd; static Tcl_ObjCmdProc InfoCmdCountCmd; static Tcl_ObjCmdProc InfoCommandsCmd; static Tcl_ObjCmdProc InfoCompleteCmd; static Tcl_ObjCmdProc InfoDefaultCmd; /* TIP #348 - New 'info' subcommand 'errorstack' */ static Tcl_ObjCmdProc InfoErrorStackCmd; /* TIP #280 - New 'info' subcommand 'frame' */ static Tcl_ObjCmdProc InfoFrameCmd; static Tcl_ObjCmdProc InfoFunctionsCmd; static Tcl_ObjCmdProc InfoHostnameCmd; static Tcl_ObjCmdProc InfoLevelCmd; static Tcl_ObjCmdProc InfoLibraryCmd; static Tcl_ObjCmdProc InfoLoadedCmd; static Tcl_ObjCmdProc InfoNameOfExecutableCmd; static Tcl_ObjCmdProc InfoPatchLevelCmd; static Tcl_ObjCmdProc InfoProcsCmd; static Tcl_ObjCmdProc InfoScriptCmd; static Tcl_ObjCmdProc InfoSharedlibCmd; static Tcl_ObjCmdProc InfoCmdTypeCmd; static Tcl_ObjCmdProc InfoTclVersionCmd; static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); static int SortCompare(SortElement *firstPtr, SortElement *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); |
| ︙ | ︙ | |||
202 203 204 205 206 207 208 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IfObjCmd( | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IfObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *boolObj;
if (objc <= 1) {
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
IfConditionCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
IfConditionCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *const *objv = (Tcl_Obj *const *)data[1];
int i = PTR2INT(data[2]);
Tcl_Obj *boolObj = (Tcl_Obj *)data[3];
int value, thenScriptIndex = 0;
const char *clause;
if (result != TCL_OK) {
TclDecrRefCount(boolObj);
return result;
}
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IncrObjCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IncrObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *newValuePtr, *incrPtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
if (objc == 3) {
incrPtr = objv[2];
} else {
TclNewIntObj(incrPtr, 1);
}
Tcl_IncrRefCount(incrPtr);
newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
incrPtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(incrPtr);
if (newValuePtr == NULL) {
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoArgsCmd( | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoArgsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Proc *procPtr;
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoBodyCmd( | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoBodyCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name, *bytes;
Proc *procPtr;
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCmdCountCmd( | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdCountCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc != 1) {
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCommandsCmd( | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCommandsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Tcl_HashEntry *entryPtr;
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
* Special case for when the pattern doesn't include any of glob's
* special characters. This lets us avoid scans of any hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
| | | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
* Special case for when the pattern doesn't include any of glob's
* special characters. This lets us avoid scans of any hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
}
}
if (entryPtr == NULL) {
tablePtr = &globalNsPtr->cmdTable;
entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
}
if (entryPtr != NULL) {
| | | | | | | 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 |
}
}
if (entryPtr == NULL) {
tablePtr = &globalNsPtr->cmdTable;
entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
}
if (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
}
} else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
/*
* The pattern is non-trivial, but either there is no explicit path or
* there is an explicit namespace in the pattern. In both cases, the
* old matching scheme is perfect.
*/
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
* If the effective namespace isn't the global :: namespace, and a
* specific namespace wasn't requested in the pattern, then add in all
* global :: commands that match the simple pattern. Of course, we add
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
* We keep a hash of the objects already added to the result list.
*/
Tcl_InitObjHashTable(&addedCommandsTable);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
* We keep a hash of the objects already added to the result list.
*/
Tcl_InitObjHashTable(&addedCommandsTable);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
elemObjPtr, &isNew);
}
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
continue;
}
if (pathNsPtr == globalNsPtr) {
foundGlobal = 1;
}
entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
continue;
}
if (pathNsPtr == globalNsPtr) {
foundGlobal = 1;
}
entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
elemObjPtr, &isNew);
if (isNew) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if (!foundGlobal) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if (!foundGlobal) {
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,
(char *) elemObjPtr) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else {
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCompleteCmd( | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCompleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command");
return TCL_ERROR;
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoDefaultCmd( | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoDefaultCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *procName, *argName;
Proc *procPtr;
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
} else {
| | > | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(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_NewWideIntObj(0));
}
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoErrorStackCmd( | | | | 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 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoErrorStackCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
Interp *iPtr;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
target = Tcl_GetChild(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
}
iPtr = (Interp *) target;
Tcl_SetObjResult(interp, iPtr->errorStack);
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoExistsCmd( | | | 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName;
Var *varPtr;
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFrameCmd( | | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFrameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int level, code = TCL_OK;
CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
break;
case TCL_LOCATION_BC: {
/*
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
| | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
break;
case TCL_LOCATION_BC: {
/*
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
CmdFrame *fPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*fPtr = *framePtr;
/*
* Note:
* Type BC => f.data.eval.path is not used.
* f.data.tebc.codePtr is used instead.
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
*/
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
| | | | 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 |
*/
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
int i;
/*
* This is a non-standard command. Luckily, it's told us how to
* render extra information about its frame.
*/
for (i=0 ; i<efiPtr->length ; i++) {
lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1);
if (efiPtr->fields[i].proc) {
lv[lc++] =
efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
} else {
lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData;
}
}
}
}
/*
* 'level'. Common to all frame types. Conditional on having an associated
|
| ︙ | ︙ | |||
1462 1463 1464 1465 1466 1467 1468 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFunctionsCmd( | | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFunctionsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *script;
int code;
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoHostnameCmd( | | | 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoHostnameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name;
if (objc != 1) {
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLevelCmd( | | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLevelCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc == 1) { /* Just "info level" */
|
| ︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLibraryCmd( | | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLibraryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *libDirName;
if (objc != 1) {
|
| ︙ | ︙ | |||
1694 1695 1696 1697 1698 1699 1700 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLoadedCmd( | | | 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLoadedCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *interpName, *packageName;
if (objc > 3) {
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoNameOfExecutableCmd( | | | 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoNameOfExecutableCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
1778 1779 1780 1781 1782 1783 1784 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoPatchLevelCmd( | | | 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoPatchLevelCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *patchlevel;
if (objc != 1) {
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoProcsCmd( | | | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoProcsCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 |
*/
listPtr = Tcl_NewListObj(0, NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
| | | | | | | | | 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 |
*/
listPtr = Tcl_NewListObj(0, NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto simpleProcOK;
}
} else {
simpleProcOK:
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
} else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
{
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);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command)cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
} else {
procOK:
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
* decided not to "fix" it in 8.3, leaving the behavior slightly
* different.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | | 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 |
* decided not to "fix" it in 8.3, leaving the behavior slightly
* different.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
&& TclIsProc(realCmdPtr))) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
|
| ︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 | * script filename. * *---------------------------------------------------------------------- */ static int InfoScriptCmd( | | > | 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 |
* script filename.
*
*----------------------------------------------------------------------
*/
static int
InfoScriptCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?filename?");
return TCL_ERROR;
}
if (objc == 2) {
if (iPtr->scriptFile != NULL) {
|
| ︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoSharedlibCmd( | | | 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoSharedlibCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2097 2098 2099 2100 2101 2102 2103 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoTclVersionCmd( | | | 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoTclVersionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *version;
if (objc != 1) {
|
| ︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 | * message. * *---------------------------------------------------------------------- */ static int InfoCmdTypeCmd( | | | | 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 |
* message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command command;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "commandName");
return TCL_ERROR;
}
command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
TCL_LEAVE_ERR_MSG);
if (command == NULL) {
return TCL_ERROR;
}
/*
* There's one special case: safe 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", NULL);
} else {
|
| ︙ | ︙ | |||
2191 2192 2193 2194 2195 2196 2197 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_JoinObjCmd( | | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int length, listLen;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
|
| ︙ | ︙ | |||
2233 2234 2235 2236 2237 2238 2239 |
(void) TclGetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
int i;
| | | 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 |
(void) TclGetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
int i;
TclNewObj(resObjPtr);
for (i = 0; i < listLen; i++) {
if (i > 0) {
/*
* NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
* to shimmer joinObjPtr. If it did, then the case where
* objv[1] and objv[2] are the same value would not be safe.
|
| ︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LassignObjCmd( | | | 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LassignObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listCopyPtr;
Tcl_Obj **listObjv; /* The contents of the list. */
int listObjc; /* The length of the list. */
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LindexObjCmd( | | < | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LindexObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2409 2410 2411 2412 2413 2414 2415 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( | | | 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LinsertObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
int index, len, result;
|
| ︙ | ︙ | |||
2491 2492 2493 2494 2495 2496 2497 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( | | | 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
|
| ︙ | ︙ | |||
2527 2528 2529 2530 2531 2532 2533 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LlengthObjCmd( | | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LlengthObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
|
| ︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LpopObjCmd( | | | 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LpopObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
Tcl_Obj *elemPtr, *stored;
|
| ︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 |
/*
* First, extract the element to be returned.
* TclLindexFlat adds a ref count which is handled.
*/
if (objc == 2) {
elemPtr = elemPtrs[listLen - 1];
Tcl_IncrRefCount(elemPtr);
} else {
elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
if (elemPtr == NULL) {
return TCL_ERROR;
| > > > > > > > > | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 |
/*
* 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", NULL);
return TCL_ERROR;
}
elemPtr = elemPtrs[listLen - 1];
Tcl_IncrRefCount(elemPtr);
} else {
elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
if (elemPtr == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2666 2667 2668 2669 2670 2671 2672 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrangeObjCmd( | | | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrangeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, first, last, result;
|
| ︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 |
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
| | | 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 |
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, idxc;
int listLen, *idxv, prevIdx, first, num;
Tcl_Obj *listObj;
|
| ︙ | ︙ | |||
2762 2763 2764 2765 2766 2767 2768 |
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
| | | 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 |
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
idxv = (int *)ckalloc((objc - 2) * sizeof(int));
for (i = 2; i < objc; i++) {
if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK) {
ckfree(idxv);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2853 2854 2855 2856 2857 2858 2859 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( | | | 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrepeatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
int elementCount, i, totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
|
| ︙ | ︙ | |||
2962 2963 2964 2965 2966 2967 2968 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreplaceObjCmd( | | | 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreplaceObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
int first, last, listLen, numToDelete, result;
|
| ︙ | ︙ | |||
3063 3064 3065 3066 3067 3068 3069 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreverseObjCmd( | | | 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreverseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj **elemv;
int elemc, i, j;
|
| ︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsearchObjCmd( | | | 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsearchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
int allocatedIndexVector = 0;
|
| ︙ | ︙ | |||
3165 3166 3167 3168 3169 3170 3171 |
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
"-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
| | | 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 |
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
"-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
enum lsearchoptions {
LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING,
LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
};
enum datatypes {
|
| ︙ | ︙ | |||
3213 3214 3215 3216 3217 3218 3219 |
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
result = TCL_ERROR;
goto done;
}
| | | 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 |
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
result = TCL_ERROR;
goto done;
}
switch ((enum lsearchoptions) index) {
case LSEARCH_ALL: /* -all */
allMatches = 1;
break;
case LSEARCH_ASCII: /* -ascii */
dataType = ASCII;
break;
case LSEARCH_BISECT: /* -bisect */
|
| ︙ | ︙ | |||
3314 3315 3316 3317 3318 3319 3320 |
if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (groupSize < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 1", -1));
| | | 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 |
if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (groupSize < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BADSTRIDE", NULL);
result = TCL_ERROR;
goto done;
}
i++;
break;
case LSEARCH_INDEX: { /* -index */
|
| ︙ | ︙ | |||
3358 3359 3360 3361 3362 3363 3364 | case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: | | | | | 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 |
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
/*
* Fill the array by parsing each index. We don't know whether
* their scale is sensible yet, but we at least perform the
* syntactic check here.
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
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", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
|
| ︙ | ︙ | |||
3522 3523 3524 3525 3526 3527 3528 |
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
| > | | 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 |
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
TclNewIntObj(itemPtr, TCL_INDEX_NONE);
Tcl_SetObjResult(interp, itemPtr);
}
goto done;
}
/*
* If start points within a group, it points to the start of the group.
*/
|
| ︙ | ︙ | |||
3649 3650 3651 3652 3653 3654 3655 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
| | | | 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
* To maintain consistancy with standard lsearch semantics, we
* must find the leftmost occurrence of the pattern in the
* list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with an
* early comparison).
*
* In bisect mode though, we want the last of equals.
*/
|
| ︙ | ︙ | |||
3811 3812 3813 3814 3815 3816 3817 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
| | > > | < | > > | < > > | | 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 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
TclNewIntObj(itemPtr, i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
TclNewIntObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
int j;
TclNewIntObj(itemPtr, index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
TclNewIntObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_SetObjResult(interp, itemPtr);
} else {
Tcl_Obj *elObj;
TclNewIntObj(elObj, index);
Tcl_SetObjResult(interp, elObj);
}
} else if (index < 0) {
/*
* Is this superfluous? The result should be a blank object by
* default...
*/
|
| ︙ | ︙ | |||
3894 3895 3896 3897 3898 3899 3900 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( | | | 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
|
| ︙ | ︙ | |||
3979 3980 3981 3982 3983 3984 3985 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsortObjCmd( | | | 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsortObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int i, j, index, indices, length, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
|
| ︙ | ︙ | |||
4065 4066 4067 4068 4069 4070 4071 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
| | | | | | | 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 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
int 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", 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
* we do not store the converted values here because we do not
* know if this is the only -index option yet and so we can't
* allocate any space; that happens after the scan through all the
* options is done.
*/
for (j=0 ; j<sortindex ; j++) {
int encoded = 0;
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", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
|
| ︙ | ︙ | |||
4177 4178 4179 4180 4181 4182 4183 | case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: | | | 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 |
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
|
| ︙ | ︙ | |||
4317 4318 4319 4320 4321 4322 4323 |
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elmArrSize = length * sizeof(SortElement);
if (elmArrSize <= MAXCALLOC) {
| | | | 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 |
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elmArrSize = length * sizeof(SortElement);
if (elmArrSize <= MAXCALLOC) {
elementArray = (SortElement *)ckalloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %d items", length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
4423 4424 4425 4426 4427 4428 4429 |
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
| | | | 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 |
listRepPtr = ListRepPtr(resultPtr);
newArray = &listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
TclNewIntObj(objPtr, idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
objPtr = listObjPtrs[idx + j - groupOffset];
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
}
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
TclNewIntObj(objPtr, elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
} else {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
objPtr = elementPtr->payload.objPtr;
newArray[i++] = objPtr;
|
| ︙ | ︙ | |||
4706 4707 4708 4709 4710 4711 4712 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
| | | 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
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 */
/*
|
| ︙ | ︙ | |||
4775 4776 4777 4778 4779 4780 4781 |
/*
* 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')) {
| | | | 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 |
/*
* 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 += TclUtfToUCS4(left, &uniLeft);
right += TclUtfToUCS4(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
* dictionary sorts are case insensitve. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
* other interesting punctuations occur).
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
1 2 3 4 5 6 7 8 | /* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters M to Z. It * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters M to Z. It * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2002 ActiveState Corporation. * Copyright © 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | /* * 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[] = | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | /* * 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[] = "\x09\x0A\x0B\x0C\x0D " /* ASCII */ "\xC0\x80" /* nul (U+0000) */ "\xC2\x85" /* next line (U+0085) */ "\xC2\xA0" /* non-breaking space (U+00a0) */ "\xE1\x9A\x80" /* ogham space mark (U+1680) */ "\xE1\xA0\x8E" /* mongolian vowel separator (U+180e) */ "\xE2\x80\x80" /* en quad (U+2000) */ "\xE2\x80\x81" /* em quad (U+2001) */ "\xE2\x80\x82" /* en space (U+2002) */ "\xE2\x80\x83" /* em space (U+2003) */ "\xE2\x80\x84" /* three-per-em space (U+2004) */ "\xE2\x80\x85" /* four-per-em space (U+2005) */ "\xE2\x80\x86" /* six-per-em space (U+2006) */ "\xE2\x80\x87" /* figure space (U+2007) */ "\xE2\x80\x88" /* punctuation space (U+2008) */ "\xE2\x80\x89" /* thin space (U+2009) */ "\xE2\x80\x8A" /* hair space (U+200a) */ "\xE2\x80\x8B" /* zero width space (U+200b) */ "\xE2\x80\xA8" /* line separator (U+2028) */ "\xE2\x80\xA9" /* paragraph separator (U+2029) */ "\xE2\x80\xAF" /* narrow no-break space (U+202f) */ "\xE2\x81\x9F" /* medium mathematical space (U+205f) */ "\xE2\x81\xA0" /* word joiner (U+2060) */ "\xE3\x80\x80" /* ideographic space (U+3000) */ "\xEF\xBB\xBF" /* zero width no-break space (U+feff) */ ; /* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PwdObjCmd( | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PwdObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegexpObjCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegexpObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength, matchLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
};
enum regexpoptions {
REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
};
indices = 0;
about = 0;
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
goto optionError;
}
| | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
goto optionError;
}
switch ((enum regexpoptions) index) {
case REGEXP_ALL:
all = 1;
break;
case REGEXP_INDICES:
indices = 1;
break;
case REGEXP_INLINE:
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
int temp;
if (++i >= objc) {
goto endOfForLoop;
}
| | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
int temp;
if (++i >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[i], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[i];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 |
/*
* It's the number of substitutions, plus one for the matchVar at
* index 0
*/
objc = info.nsubs + 1;
if (all <= 1) {
| | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 |
/*
* It's the number of substitutions, plus one for the matchVar at
* index 0
*/
objc = info.nsubs + 1;
if (all <= 1) {
TclNewObj(resultPtr);
}
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
end--;
}
} else {
start = -1;
end = -1;
}
| | | | | 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 |
end--;
}
} else {
start = -1;
end = -1;
}
TclNewIntObj(objs[0], start);
TclNewIntObj(objs[1], end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (i <= info.nsubs) {
newPtr = Tcl_GetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
TclNewObj(newPtr);
}
}
if (doinline) {
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegsubObjCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegsubObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match, command, numParts;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
"-all", "-command", "-expanded", "-line",
"-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
enum regsubobjoptions {
REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option",
TCL_EXACT, &index) != TCL_OK) {
goto optionError;
}
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option",
TCL_EXACT, &index) != TCL_OK) {
goto optionError;
}
switch ((enum regsubobjoptions) index) {
case REGSUB_ALL:
all = 1;
break;
case REGSUB_NOCASE:
cflags |= TCL_REG_NOCASE;
break;
case REGSUB_COMMAND:
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
int temp;
if (++idx >= objc) {
goto endOfForLoop;
}
| | | 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
int temp;
if (++idx >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[idx], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[idx];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
| | | | 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 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
args = (Tcl_Obj **)ckalloc(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;
if ((subStart >= 0) && (subEnd >= 0)) {
args[idx + numParts] = Tcl_NewUnicodeObj(
wstring + offset + subStart, subEnd - subStart);
} else {
TclNewObj(args[idx + numParts]);
}
Tcl_IncrRefCount(args[idx + numParts]);
}
/*
* At this point, we're locally holding the references to the
* argument words we added for this time round the loop, and the
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RenameObjCmd( | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RenameObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *oldName, *newName;
if (objc != 3) {
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ReturnObjCmd( | | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReturnObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int code, level;
Tcl_Obj *returnOpts;
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SourceObjCmd( | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SourceObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
int result;
|
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 |
};
int index;
if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
"option", TCL_EXACT, &index)) {
return TCL_ERROR;
}
| | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 |
};
int index;
if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
"option", TCL_EXACT, &index)) {
return TCL_ERROR;
}
pkgFiles = (void **)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
/* Make sure that during the following TclNREvalFile no filenames
* are recorded for inclusion in the "package files" command */
names = *pkgFiles;
*pkgFiles = NULL;
}
result = TclNREvalFile(interp, fileName, encodingName);
if (pkgFiles) {
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SplitObjCmd( | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
int 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.
*/
} else if (splitCharLen == 0) {
Tcl_HashTable charReuseTable;
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 |
* 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) {
| < | < < < < < < < < < < < < < | < | | | | | | 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 |
* 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 = TclUtfToUCS4(stringPtr, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
* Don't need to fiddle with refcount...
*/
Tcl_SetHashValue(hPtr, objPtr);
} else {
objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
const char *p;
/*
* Handle the special case of splitting on a single character. This is
* only true for the one-char ASCII case, as one unicode char is > 1
* byte in length.
*/
while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
stringPtr = p + 1;
}
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
const char *element, *p, *splitEnd;
int splitLen;
int splitChar;
/*
* 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 = TclUtfToUCS4(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUCS4(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = stringPtr + len;
break;
}
}
|
| ︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringFirstCmd( | | | < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringFirstCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?startIndex?");
return TCL_ERROR;
}
if (objc == 4) {
int size = Tcl_GetCharLength(objv[2]);
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringLastCmd --
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLastCmd( | | | < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLastCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int last = INT_MAX - 1;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
if (objc == 4) {
int size = Tcl_GetCharLength(objv[2]);
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringIndexCmd --
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIndexCmd( | | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIndexCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, index;
if (objc != 3) {
|
| ︙ | ︙ | |||
1437 1438 1439 1440 1441 1442 1443 |
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
| | | 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
length = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (length < 3)) {
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringInsertCmd( | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringInsertCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
int length; /* String length */
int index; /* Insert index */
Tcl_Obj *outObj; /* Output object */
|
| ︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIsCmd( | | < | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
int i, failat = 0, result = 1, strict = 0, index, length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
"list", "lower", "print", "punct",
"space", "true", "upper", "wideinteger",
"wordchar", "xdigit", NULL
};
enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE,
STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
};
enum isOptionsEnum {
OPT_STRICT, OPT_FAILIDX
};
if (objc < 3 || objc > 6) {
Tcl_WrongNumArgs(interp, 1, objv,
"class ?-strict? ?-failindex var? str");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 |
for (i = 2; i < objc-1; i++) {
int idx2;
if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0,
&idx2) != TCL_OK) {
return TCL_ERROR;
}
| | | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 |
for (i = 2; i < objc-1; i++) {
int idx2;
if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0,
&idx2) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum isOptionsEnum) idx2) {
case OPT_STRICT:
strict = 1;
break;
case OPT_FAILIDX:
if (i+1 >= objc-1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-strict? ?-failindex var? str");
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 |
objPtr = objv[objc-1];
/*
* When entering here, result == 1 and failat == 0.
*/
| | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 |
objPtr = objv[objc-1];
/*
* When entering here, result == 1 and failat == 0.
*/
switch ((enum isClassesEnum) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
case STR_IS_ALPHA:
chcomp = Tcl_UniCharIsAlpha;
break;
case STR_IS_ASCII:
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 | * the number of bytes when parsing strings with non-ASCII * characters in them. * * Skip leading spaces first. This is only really an issue * if it is the first "element" that has the failure. */ | | | 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
* the number of bytes when parsing strings with non-ASCII
* characters in them.
*
* Skip leading spaces first. This is only really an issue
* if it is the first "element" that has the failure.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
failat = Tcl_GetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
|
| ︙ | ︙ | |||
1904 1905 1906 1907 1908 1909 1910 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
| | < < < < < < | < > | | | | | > | 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 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
length2 = TclUtfToUCS4(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
}
}
}
/*
* Only set the failVarObj when we will return 0 and we have indicated a
* valid fail index (>= 0).
*/
str_is_done:
if ((result == 0) && (failVarObj != NULL)) {
TclNewIntObj(objPtr, failat);
if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
UniCharIsAscii(
|
| ︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMapCmd( | | | 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMapCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2, mapElemc, index;
int nocase = 0, mapWithDict = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
|
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 | mapWithDict = 1; /* * Copy the dictionary out into an array; that's the easiest way to * adapt this code... */ | | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
mapWithDict = 1;
/*
* Copy the dictionary out into an array; that's the easiest way to
* adapt this code...
*/
mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (i=2 ; i<mapElemc ; i+=2) {
Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
}
Tcl_DictObjDone(&search);
} else {
|
| ︙ | ︙ | |||
2144 2145 2146 2147 2148 2149 2150 | /* * Precompute pointers to the unicode string and length. This saves us * repeated function calls later, significantly speeding up the * algorithm. We only need the lowercase first char in the nocase * case. */ | | | | | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
/*
* Precompute pointers to the unicode string and length. This saves us
* repeated function calls later, significantly speeding up the
* algorithm. We only need the lowercase first char in the nocase
* case.
*/
mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
mapLens = (int *)TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
if (nocase) {
u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
mapLens+index);
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
|
| ︙ | ︙ | |||
2240 2241 2242 2243 2244 2245 2246 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMatchCmd( | | | 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMatchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int nocase = 0;
if (objc < 3 || objc > 4) {
|
| ︙ | ︙ | |||
2292 2293 2294 2295 2296 2297 2298 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRangeCmd( | | | 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRangeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, first, last;
if (objc != 4) {
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringReptCmd( | | | 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringReptCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int count;
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
2404 2405 2406 2407 2408 2409 2410 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRplcCmd( | | | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRplcCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, last, length, end;
if (objc < 4 || objc > 5) {
|
| ︙ | ︙ | |||
2480 2481 2482 2483 2484 2485 2486 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRevCmd( | | | < < | | | | > | < | < | | > | > > > | > | > > > > > > | | < | | | | > | < | < | | | | > | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRevCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringStartCmd --
*
* This procedure is invoked to process the "string wordstart" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringStartCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const Tcl_UniChar *p, *string;
int cur, index, length;
Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
string = Tcl_GetUnicodeFromObj(objv[1], &length);
if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index >= length) {
index = length - 1;
}
cur = 0;
if (index > 0) {
p = &string[index];
(void)TclUniCharToUCS4(p, &ch);
for (cur = index; cur >= 0; cur--) {
int delta = 0;
const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
next = TclUCS4Prev(p, string);
do {
next += delta;
delta = TclUniCharToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
if (cur != index) {
cur += 1;
}
}
TclNewIntObj(obj, cur);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEndCmd --
*
* This procedure is invoked to process the "string wordend" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEndCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const Tcl_UniChar *p, *end, *string;
int cur, index, length;
Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
string = Tcl_GetUnicodeFromObj(objv[1], &length);
if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index < length) {
p = &string[index];
end = string+length;
for (cur = index; p < end; cur++) {
p += TclUniCharToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = length;
}
TclNewIntObj(obj, cur);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEqualCmd --
|
| ︙ | ︙ | |||
2638 2639 2640 2641 2642 2643 2644 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringEqualCmd( | | | 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEqualCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
|
| ︙ | ︙ | |||
2713 2714 2715 2716 2717 2718 2719 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCmpCmd( | | | 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCmpCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
|
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCatCmd( | | | 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objResultPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int StringBytesCmd( | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 |
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringBytesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length;
if (objc != 2) {
|
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLenCmd( | | | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLenCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2917 2918 2919 2920 2921 2922 2923 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLowerCmd( | | | 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLowerCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
3002 3003 3004 3005 3006 3007 3008 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringUpperCmd( | | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringUpperCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
3087 3088 3089 3090 3091 3092 3093 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTitleCmd( | | | 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTitleCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
|
| ︙ | ︙ | |||
3172 3173 3174 3175 3176 3177 3178 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimCmd( | | | 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int triml, trimr, length1, length2;
|
| ︙ | ︙ | |||
3219 3220 3221 3222 3223 3224 3225 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimLCmd( | | | 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimLCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim, length1, length2;
|
| ︙ | ︙ | |||
3265 3266 3267 3268 3269 3270 3271 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimRCmd( | | | 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim, length1, length2;
|
| ︙ | ︙ | |||
3408 3409 3410 3411 3412 3413 3414 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
| | | | | 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 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags;
if (objc < 2) {
|
| ︙ | ︙ | |||
3456 3457 3458 3459 3460 3461 3462 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SwitchObjCmd( | | | | | 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SwitchObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
int noCase, patternLength;
const char *pattern;
|
| ︙ | ︙ | |||
3492 3493 3494 3495 3496 3497 3498 |
* -glob, you *must* fix TclCompileSwitchCmd's option parser as well.
*/
static const char *const options[] = {
"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
"--", NULL
};
| | | | 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 |
* -glob, you *must* fix TclCompileSwitchCmd's option parser as well.
*/
static const char *const options[] = {
"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
"--", NULL
};
enum switchOptionsEnum {
OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP,
OPT_LAST
};
typedef int (*strCmpFn_t)(const char *, const char *);
strCmpFn_t strCmpFn = TclUtfCmp;
mode = OPT_EXACT;
foundmode = 0;
indexVarObj = NULL;
matchVarObj = NULL;
numMatchesSaved = 0;
noCase = 0;
for (i = 1; i < objc-2; i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum switchOptionsEnum) index) {
/*
* General options.
*/
case OPT_LAST:
i++;
goto finishedOptions;
|
| ︙ | ︙ | |||
3783 3784 3785 3786 3787 3788 3789 |
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end > 0) {
| | | > | | 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 |
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end > 0) {
TclNewIntObj(rangeObjAry[0], info.matches[j].start);
TclNewIntObj(rangeObjAry[1], info.matches[j].end-1);
} else {
TclNewIntObj(rangeObjAry[1], TCL_INDEX_NONE);
rangeObjAry[0] = rangeObjAry[1];
}
/*
* Never fails; the object is always clean at this point.
*/
Tcl_ListObjAppendElement(NULL, indicesObj,
|
| ︙ | ︙ | |||
3848 3849 3850 3851 3852 3853 3854 |
/*
* We've got a match. Find a body to execute, skipping bodies that are
* "-".
*/
matchFound:
| | | 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 |
/*
* We've got a match. Find a body to execute, skipping bodies that are
* "-".
*/
matchFound:
ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
/*
* We have to perform the GetSrc and other type dependent handling of
* the frame here because we are munging with the line numbers,
* something the other commands like if, etc. are not doing. Them are
|
| ︙ | ︙ | |||
3878 3879 3880 3881 3882 3883 3884 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
| | | | 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 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
/*
* This is either a dynamic code word, when all elements are
* relative to themselves, or something else less expected and
* where we have no information. The result is the same in both
* cases; tell the code to come that it doesn't know where it is,
* which triggers reversion to the old behavior.
*/
int k;
ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
}
}
}
|
| ︙ | ︙ | |||
3932 3933 3934 3935 3936 3937 3938 |
ClientData data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
| | | | 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 |
ClientData data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
CmdFrame *ctxPtr = (CmdFrame *)data[1];
int pc = PTR2INT(data[2]);
const char *pattern = (const char *)data[3];
int patternLength = strlen(pattern);
/*
* Clean up TIP 280 context information
*/
if (splitObjs) {
|
| ︙ | ︙ | |||
3986 3987 3988 3989 3990 3991 3992 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ThrowObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options;
int len;
|
| ︙ | ︙ | |||
4051 4052 4053 4054 4055 4056 4057 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeObjCmd( | | | 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
int i, result;
|
| ︙ | ︙ | |||
4149 4150 4151 4152 4153 4154 4155 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeRateObjCmd( | | | 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeRateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static double measureOverhead = 0;
/* global measure-overhead */
double overhead = -1; /* given measure-overhead */
|
| ︙ | ︙ | |||
4179 4180 4181 4182 4183 4184 4185 |
Tcl_WideInt start, middle, stop;
#ifndef TCL_WIDE_CLICKS
Tcl_Time now;
#endif /* !TCL_WIDE_CLICKS */
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
| | | > > | 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 |
Tcl_WideInt start, middle, stop;
#ifndef TCL_WIDE_CLICKS
Tcl_Time now;
#endif /* !TCL_WIDE_CLICKS */
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
enum timeRateOptionsEnum {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
ByteCode *codePtr = NULL;
for (i = 1; i < objc - 1; i++) {
int index;
if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
break;
}
if (index == TMRT_LAST) {
i++;
break;
}
switch ((enum timeRateOptionsEnum)index) {
case TMRT_EV_DIRECT:
direct = objv[i];
break;
case TMRT_OVERHEAD:
if (++i >= objc - 1) {
goto usage;
}
if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) {
return TCL_ERROR;
}
break;
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
case TMRT_LAST:
break;
}
}
if (i >= objc || i < objc - 3) {
usage:
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
4325 4326 4327 4328 4329 4330 4331 |
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
| | | 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 |
}
if (maxms == 0) {
/*
* Reset last measurement overhead
*/
measureOverhead = 0;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
/*
* If time is negative, make current overhead more precise.
*/
|
| ︙ | ︙ | |||
4556 4557 4558 4559 4560 4561 4562 |
* convert execution time (in wide clicks) to microsecs.
*/
usec *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
| > | | 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 |
* convert execution time (in wide clicks) to microsecs.
*/
usec *= TclpWideClickInMicrosec();
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
TclNewIntObj(objs[4], 0);
objs[0] = objs[2] = objs[4];
goto retRes;
}
/*
* If not calibrating...
*/
|
| ︙ | ︙ | |||
4597 4598 4599 4600 4601 4602 4603 |
objs[0] = Tcl_NewDoubleObj(measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = usec / count; /* microsecs per iteration */
if (val >= 1000000) {
| | | | 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 |
objs[0] = Tcl_NewDoubleObj(measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = usec / count; /* microsecs per iteration */
if (val >= 1000000) {
TclNewIntObj(objs[0], val);
} else {
if (val < 10) {
digits = 6;
} else if (val < 100) {
digits = 4;
} else if (val < 1000) {
digits = 3;
} else if (val < 10000) {
digits = 2;
} else {
digits = 1;
}
objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
}
TclNewIntObj(objs[2], count); /* iterations */
/*
* Calculate speed as rate (count) per sec
*/
if (!usec) {
usec++; /* Avoid divide by zero. */
|
| ︙ | ︙ | |||
4635 4636 4637 4638 4639 4640 4641 |
digits = 2;
} else {
digits = 1;
}
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / usec);
} else {
| | | | 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 |
digits = 2;
} else {
digits = 1;
}
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / usec);
} else {
TclNewIntObj(objs[4], val);
}
} else {
objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
}
retRes:
/*
* Estimated net execution time (in millisecs).
*/
if (!calibrate) {
if (usec >= 1) {
objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
} else {
TclNewIntObj(objs[6], 0);
}
TclNewLiteralStringObj(objs[7], "net-ms");
}
/*
* Construct the result as a list because many programs have always
* parsed as such (extracting the first element, typically).
|
| ︙ | ︙ | |||
4692 4693 4694 4695 4696 4697 4698 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TryObjCmd( | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TryObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
int i, bodyShared, haveHandlers, dummy, code;
static const char *const handlerNames[] = {
|
| ︙ | ︙ | |||
4728 4729 4730 4731 4732 4733 4734 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"body ?handler ...? ?finally script?");
return TCL_ERROR;
}
bodyObj = objv[1];
| | | 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"body ?handler ...? ?finally script?");
return TCL_ERROR;
}
bodyObj = objv[1];
TclNewObj(handlersObj);
bodyShared = 0;
haveHandlers = 0;
for (i=2 ; i<objc ; i++) {
int type;
Tcl_Obj *info[5];
if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
|
| ︙ | ︙ | |||
4905 4906 4907 4908 4909 4910 4911 |
static int
TryPostBody(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
| | | | | | 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 |
static int
TryPostBody(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
int i, code, objc;
int numHandlers = 0;
handlersObj = (Tcl_Obj *)data[0];
finallyObj = (Tcl_Obj *)data[1];
objv = (Tcl_Obj **)data[2];
objc = PTR2INT(data[3]);
cmdObj = objv[0];
/*
* Check for limits/rewinding, which override normal trapping behaviour.
*/
|
| ︙ | ︙ | |||
4956 4957 4958 4959 4960 4961 4962 4963 |
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
| > | | 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 |
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
int numElems = 0;
Tcl_ListObjGetElements(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
continue;
}
/*
|
| ︙ | ︙ | |||
5019 5020 5021 5022 5023 5024 5025 | /* * Bind the variables. We already know this is a list of variable * names, but it might be empty. */ Tcl_ResetResult(interp); result = TCL_ERROR; | | | | | 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 |
/*
* Bind the variables. We already know this is a list of variable
* names, but it might be empty.
*/
Tcl_ResetResult(interp);
result = TCL_ERROR;
Tcl_ListObjLength(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);
goto handlerFailed;
}
Tcl_DecrRefCount(resultObj);
if (numElems> 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
goto handlerFailed;
}
}
} else {
|
| ︙ | ︙ | |||
5123 5124 5125 5126 5127 5128 5129 |
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
Tcl_Obj *finallyObj;
int finally;
| | | | | 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 |
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
Tcl_Obj *finallyObj;
int finally;
objv = (Tcl_Obj **)data[0];
options = (Tcl_Obj *)data[1];
handlerKindObj = (Tcl_Obj *)data[2];
finally = PTR2INT(data[3]);
cmdObj = objv[0];
finallyObj = finally ? objv[finally] : 0;
/*
* Check for limits/rewinding, which override normal trapping behaviour.
|
| ︙ | ︙ | |||
5207 5208 5209 5210 5211 5212 5213 |
TryPostFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *cmdObj;
| | | | | 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 |
TryPostFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *cmdObj;
resultObj = (Tcl_Obj *)data[0];
options = (Tcl_Obj *)data[1];
cmdObj = (Tcl_Obj *)data[2];
/*
* If the result wasn't OK, we need to adjust the result options.
*/
if (result != TCL_OK) {
Tcl_DecrRefCount(resultObj);
|
| ︙ | ︙ | |||
5268 5269 5270 5271 5272 5273 5274 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_WhileObjCmd( | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_WhileObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ForIterData *iterPtr;
if (objc != 3) {
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
1 2 3 4 5 6 |
/*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various Tcl
* commands into a sequence of instructions ("bytecodes").
*
| | | | | | | | < < | < < | | | < < | < < | < < | < < | 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 |
/*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various Tcl
* commands into a sequence of instructions ("bytecodes").
*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
*/
static AuxDataDupProc DupDictUpdateInfo;
static AuxDataFreeProc FreeDictUpdateInfo;
static AuxDataPrintProc PrintDictUpdateInfo;
static AuxDataPrintProc DisassembleDictUpdateInfo;
static AuxDataDupProc DupForeachInfo;
static AuxDataFreeProc FreeForeachInfo;
static AuxDataPrintProc PrintForeachInfo;
static AuxDataPrintProc DisassembleForeachInfo;
static AuxDataPrintProc PrintNewForeachInfo;
static AuxDataPrintProc DisassembleNewForeachInfo;
static int CompileEachloopCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr, int collect);
static int CompileDictEachCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr, int collect);
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 141 142 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
| > < | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
} else if (numWords == 2) {
/*
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
*/
int
TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
*/
int
TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
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 *tokenPtr;
int isScalar, localIndex;
if (parsePtr->numWords != 2) {
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dataTokenPtr = TokenAfter(varTokenPtr);
| | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
dataTokenPtr = TokenAfter(varTokenPtr);
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
&& Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
isDataEven = (isDataValid && (len & 1) == 0);
/*
* Special case: literal odd-length argument is always an error.
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
| | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 | * runtime. * *---------------------------------------------------------------------- */ int TclCompileBreakCmd( | | | < | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileBreakCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
if (parsePtr->numWords != 1) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
*/
int
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
*/
int
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
int resultIndex, optsIndex, range, dropScript = 0;
int depth = TclGetStackDepth(envPtr);
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
*/
|
| ︙ | ︙ | |||
761 762 763 764 765 766 767 | * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileClockClicksCmd( | | | < | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
* command at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileClockClicksCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token* tokenPtr;
switch (parsePtr->numWords) {
case 1:
/*
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 | * * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds. *---------------------------------------------------------------------- */ int TclCompileClockReadingCmd( | | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
*
* Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds.
*----------------------------------------------------------------------
*/
int
TclCompileClockReadingCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
*/
int
TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
*/
int
TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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_Obj *objPtr, *listObj;
Tcl_Token *tokenPtr;
int i;
|
| ︙ | ︙ | |||
888 889 890 891 892 893 894 |
}
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
| | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
}
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
TclNewObj(listObj);
for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(listObj);
listObj = NULL;
break;
}
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 | * runtime. * *---------------------------------------------------------------------- */ int TclCompileContinueCmd( | | | < | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileContinueCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
/*
* There should be no argument after the "continue".
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
*/
int
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
*/
int
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
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 *tokenPtr;
int i, dictVarIndex;
Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
*/
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 |
}
int
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 |
}
int
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
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 *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 |
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 |
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 |
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
}
/*
* See if we can build the value at compile time...
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
| | | | | 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 |
}
/*
* See if we can build the value at compile time...
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(dictObj);
Tcl_IncrRefCount(dictObj);
for (i=1 ; i<parsePtr->numWords ; i+=2) {
TclNewObj(keyObj);
Tcl_IncrRefCount(keyObj);
if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(dictObj);
goto nonConstant;
}
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(valueObj);
Tcl_IncrRefCount(valueObj);
if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) {
Tcl_DecrRefCount(keyObj);
Tcl_DecrRefCount(valueObj);
Tcl_DecrRefCount(dictObj);
goto nonConstant;
}
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
| | | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
duiPtr->length = numVars;
keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
/*
* Put keys to one side for later compilation to bytecode.
*/
|
| ︙ | ︙ | |||
2286 2287 2288 2289 2290 2291 2292 |
*/
static ClientData
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
| | | | | | | | | | | | > | | 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 |
*/
static ClientData
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
ClientData clientData)
{
ckfree(clientData);
}
static void
PrintDictUpdateInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
static void
DisassembleDictUpdateInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
Tcl_Obj *variables;
TclNewObj(variables);
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
Tcl_NewWideIntObj(duiPtr->varIndices[i]));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
variables);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 |
*/
int
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > > > < < < | 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 |
*/
int
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
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 *tokenPtr;
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
/*
* Handle the message.
*/
|
| ︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 |
*/
int
TclCompileExprCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 |
*/
int
TclCompileExprCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
if (parsePtr->numWords == 1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 |
*/
int
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 |
*/
int
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
if (parsePtr->numWords != 5) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the for
|
| ︙ | ︙ | |||
2692 2693 2694 2695 2696 2697 2698 |
*/
static int
CompileEachloopCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
static int
CompileEachloopCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
{
DefineLineInformation; /* TIP #280 */
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
int numWords, numLists, i, j, code = TCL_OK;
Tcl_Obj *varListObj = NULL;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
if (procPtr == NULL) {
|
| ︙ | ︙ | |||
2743 2744 2745 2746 2747 2748 2749 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
| | | | | 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 |
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
* pointing to the ForeachInfo structure.
*/
numLists = (numWords - 2)/2;
infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
/*
* Parse each var list into sequence of var names. Don't
* compile the foreach inline if any var name needs substitutions or isn't
* a scalar, or if any var list needs substitutions.
*/
TclNewObj(varListObj);
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
ForeachVarList *varListPtr;
int numVars;
if (i%2 != 1) {
|
| ︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
| | | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
|
| ︙ | ︙ | |||
2908 2909 2910 2911 2912 2913 2914 |
*/
static ClientData
DupForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
| | | | | 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 |
*/
static ClientData
DupForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
|
| ︙ | ︙ | |||
2957 2958 2959 2960 2961 2962 2963 |
*/
static void
FreeForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
| | | 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 |
*/
static void
FreeForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
int i;
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
ckfree(listPtr);
|
| ︙ | ︙ | |||
2990 2991 2992 2993 2994 2995 2996 |
*----------------------------------------------------------------------
*/
static void
PrintForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
| | | | | 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 |
*----------------------------------------------------------------------
*/
static void
PrintForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_AppendToObj(appendObj, "data=[", -1);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
|
| ︙ | ︙ | |||
3030 3031 3032 3033 3034 3035 3036 |
}
}
static void
PrintNewForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
| | | | | 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 |
}
}
static void
PrintNewForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=",
infoPtr->loopCtTemp);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
|
| ︙ | ︙ | |||
3060 3061 3062 3063 3064 3065 3066 |
}
}
static void
DisassembleForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
| | | | | | | | | | | | | | | | | | 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 |
}
}
static void
DisassembleForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Data stores.
*/
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
/*
* Loop counter.
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
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);
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
static void
DisassembleNewForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Jump offset.
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
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);
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
/*
|
| ︙ | ︙ | |||
3163 3164 3165 3166 3167 3168 3169 |
*/
int
TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 |
*/
int
TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
const char *bytes, *start;
int i, j, len;
|
| ︙ | ︙ | |||
3186 3187 3188 3189 3190 3191 3192 |
}
/*
* Check if the argument words are all compile-time-known literals; that's
* a case we can handle by compiling to a constant.
*/
| | | | | 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 |
}
/*
* Check if the argument words are all compile-time-known literals; that's
* a case we can handle by compiling to a constant.
*/
TclNewObj(formatObj);
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(objv[i]);
Tcl_IncrRefCount(objv[i]);
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
goto checkForStringConcatCase;
}
}
/*
|
| ︙ | ︙ | |||
3289 3290 3291 3292 3293 3294 3295 |
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
start = Tcl_GetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
| | | | 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 |
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
start = Tcl_GetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
TclNewObj(tmpObj); /* The buffer used to accumulate the literal
* 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) {
PushLiteral(envPtr, b, len);
Tcl_DecrRefCount(tmpObj);
TclNewObj(tmpObj);
i++;
}
/*
* Push the code to produce the string that would be
* substituted with %s, except we'll be concatenating
* directly.
|
| ︙ | ︙ | |||
3469 3470 3471 3472 3473 3474 3475 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
| | | | | < | | 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 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
last = &name[nameLen-1];
if (*last == ')') {
for (p = name; p < last; p++) {
if (*p == '(') {
elName = p + 1;
elNameLen = last - elName;
nameLen = p - name;
break;
}
}
}
if (!(flags & TCL_NO_ELEMENT) && elNameLen) {
/*
* An array element, the element name is a simple string:
* assemble the corresponding token.
*/
elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = elNameLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (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) {
int remainingLen;
|
| ︙ | ︙ | |||
3543 3544 3545 3546 3547 3548 3549 |
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
| | | 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 |
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
|
| ︙ | ︙ | |||
3576 3577 3578 3579 3580 3581 3582 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
| | | 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p++) {
if ((*p == ':') && (*(p+1) == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
1 2 3 4 5 6 7 |
/*
* tclCompCmdsGR.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 'g' through 'r') into a sequence
* of instructions ("bytecodes").
*
| | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
/*
* tclCompCmdsGR.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 'g' through 'r') into a sequence
* of instructions ("bytecodes").
*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
|
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
int before,
int after,
int *indexPtr)
{
| | > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
int before,
int after,
int *indexPtr)
{
Tcl_Obj *tmpObj;
int result = TCL_ERROR;
TclNewObj(tmpObj);
if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
}
Tcl_DecrRefCount(tmpObj);
return result;
}
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
*/
int
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
*/
int
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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;
int localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
*/
int
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
int
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
int boolVal; /* Value of static condition. */
int compileScripts = 1;
/*
* Only compile the "if" command if all arguments are simple words, in
* order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
467 468 469 470 471 472 473 |
*/
int
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
*/
int
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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, immValue;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
if (parsePtr->numWords == 1) {
return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
| | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
if (parsePtr->numWords == 1) {
return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
bytes = TclGetString(objPtr);
/*
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
notCompilable:
Tcl_DecrRefCount(objPtr);
return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileInfoCoroutineCmd(
| | | < | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 |
notCompilable:
Tcl_DecrRefCount(objPtr);
return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileInfoCoroutineCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info coroutine] without arguments.
*/
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
}
int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
}
int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
* Decide if we can use a frame slot for the var/array name or if we need
|
| ︙ | ︙ | |||
713 714 715 716 717 718 719 |
}
int
TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
}
int
TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info level] without arguments or with a single argument.
*/
if (parsePtr->numWords == 1) {
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
}
int
TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | < | 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 |
}
int
TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
return TCL_OK;
}
int
TclCompileInfoObjectIsACmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* We only handle [info object isa object <somevalue>]. The first three
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
}
int
TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
}
int
TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
*/
int
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
*/
int
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
/*
* If we are doing an assignment, push the new value. In the no values
* case, create an empty object.
*/
if (numWords > 2) {
| | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
/*
* If we are doing an assignment, push the new value. In the no values
* case, create an empty object.
*/
if (numWords > 2) {
valueTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 2);
}
/*
* Emit instructions to set/get the variable.
*/
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 |
*/
int
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
*/
int
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
int isScalar, localIndex, numWords, idx;
numWords = parsePtr->numWords;
/*
* Check for command syntax error, but we'll punt that to runtime.
*/
|
| ︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 |
*/
int
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | | 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 |
*/
int
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = parsePtr->numWords;
/*
* Quit if not enough args.
*/
/* TODO: Consider support for compiling expanded args. */
if (numWords <= 1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
*/
int
TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
*/
int
TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *valueTokenPtr;
int i, numWords, concat, build;
Tcl_Obj *listObj, *objPtr;
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 |
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
numWords = parsePtr->numWords;
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
| | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
/*
* Test if all arguments are compile-time known. If they are, we can
* implement with a simple push.
*/
numWords = parsePtr->numWords;
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(listObj);
for (i = 1; i < numWords && listObj != NULL; i++) {
TclNewObj(objPtr);
if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) {
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
} else {
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(listObj);
listObj = NULL;
}
|
| ︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 |
*/
int
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
*/
int
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, varTokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1300 1301 1302 1303 1304 1305 1306 |
*/
int
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
*/
int
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
*/
int
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
*/
int
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx, i;
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
*/
int
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 |
*/
int
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
*/
int
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < > < | 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 |
*/
int
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int tempDepth; /* Depth used for emitting one part of the
* code burst. */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the variable name. */
int localIndex; /* Index of var in local var table. */
int isScalar; /* Flag == 1 if scalar, 0 if array. */
int i;
/*
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
|
| ︙ | ︙ | |||
1772 1773 1774 1775 1776 1777 1778 | * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileNamespaceCurrentCmd( | | | < | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
* command at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileNamespaceCurrentCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [namespace current] without arguments.
*/
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
}
int
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 |
}
int
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
|
| ︙ | ︙ | |||
1850 1851 1852 1853 1854 1855 1856 |
}
int
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | < < > | 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 |
}
int
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr);
return TCL_OK;
}
int
TclCompileNamespaceQualifiersCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int off;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
}
int
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 |
}
int
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = TokenAfter(parsePtr->tokenPtr);
JumpFixup jumpFixup;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
}
int
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
}
int
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/*
* Only compile [namespace upvar ...]: needs an even number of args, >=4
|
| ︙ | ︙ | |||
2006 2007 2008 2009 2010 2011 2012 |
}
int
TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 |
}
int
TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr, *opt;
int idx;
if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
|
| ︙ | ︙ | |||
2070 2071 2072 2073 2074 2075 2076 |
*/
int
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < > < | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 |
*/
int
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
int i, len, nocase, exact, sawLast, simple;
const char *str;
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 |
*/
int
TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < | 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
*/
int
TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
* We only compile the case with [regsub -all] where the pattern is both
* known at compile time and simple (i.e., no RE metacharacters). That is,
* the pattern must be translatable into a glob like "*foo*" with no other
* glob metacharacters inside it; there must be some "foo" in there too.
|
| ︙ | ︙ | |||
2287 2288 2289 2290 2291 2292 2293 |
/*
* Get the pattern into patternObj, checking for "--" in the process.
*/
Tcl_DStringInit(&pattern);
tokenPtr = TokenAfter(tokenPtr);
| | | | | 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 |
/*
* Get the pattern into patternObj, checking for "--" in the process.
*/
Tcl_DStringInit(&pattern);
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(patternObj);
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
if (TclGetString(patternObj)[0] == '-') {
if (strcmp(TclGetString(patternObj), "--") != 0
|| parsePtr->numWords == 5) {
goto done;
}
tokenPtr = TokenAfter(tokenPtr);
Tcl_DecrRefCount(patternObj);
TclNewObj(patternObj);
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
} else if (parsePtr->numWords == 6) {
goto done;
}
/*
* Identify the code which produces the string to apply the substitution
* to (stringTokenPtr), and the replacement string (into replacementObj).
*/
stringTokenPtr = TokenAfter(tokenPtr);
tokenPtr = TokenAfter(stringTokenPtr);
TclNewObj(replacementObj);
if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
goto done;
}
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 |
*/
int
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
int
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Check for special case which can always be compiled:
* return -options <opts> <msg>
* Unlike the normal [return] compilation, this version does everything at
* runtime so it can handle arbitrary words and not just literals. Note
* that if INST_RETURN_STK wasn't already needed for something else
|
| ︙ | ︙ | |||
2451 2452 2453 2454 2455 2456 2457 |
return TCL_OK;
}
/*
* Allocate some working space.
*/
| | | | 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 |
return TCL_OK;
}
/*
* Allocate some working space.
*/
objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
/*
* Scan through the return options. If any are unknown at compile time,
* there is no value in bytecompiling. Save the option values known in an
* objv array for merging into a return options dictionary.
*
* TODO: There is potential for improvement if all option keys are known
* at compile time and all option values relating to '-code' and '-level'
* are known at compile time.
*/
for (objc = 0; objc < numOptionWords; objc++) {
TclNewObj(objv[objc]);
Tcl_IncrRefCount(objv[objc]);
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
/*
* Non-literal, so punt to run-time assembly of the dictionary.
*/
for (; objc>=0 ; objc--) {
|
| ︙ | ︙ | |||
2662 2663 2664 2665 2666 2667 2668 |
*/
int
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | | 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 |
*/
int
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
numWords = parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
/*
* Push the frame index if it is known at compile time
*/
TclNewObj(objPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
CallFrame *framePtr;
const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
/*
* Attempt to convert to a level reference. Note that TclObjGetFrame
|
| ︙ | ︙ | |||
2769 2770 2771 2772 2773 2774 2775 |
*/
int
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 |
*/
int
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 | * None. * *---------------------------------------------------------------------- */ static int IndexTailVarIfKnown( | | | 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 |
* None.
*
*----------------------------------------------------------------------
*/
static int
IndexTailVarIfKnown(
TCL_UNUSED(Tcl_Interp *),
Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Obj *tailPtr;
const char *tailName, *p;
int len, n = varTokenPtr->numComponents;
Tcl_Token *lastTokenPtr;
|
| ︙ | ︙ | |||
2943 2944 2945 2946 2947 2948 2949 |
*/
int
TclCompileObjectNextCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 |
*/
int
TclCompileObjectNextCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords > 255) {
|
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 |
}
int
TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | | < | 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 |
}
int
TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
return TCL_ERROR;
}
for (i=0 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
return TCL_OK;
}
int
TclCompileObjectSelfCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* We only handle [self] and [self object] (which is the same operation).
* These are the only very common operations on [self] for which
* bytecoding is at all reasonable.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
1 2 3 4 5 6 7 8 |
/*
* tclCompCmdsSZ.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 's' through 'z', except for
* [upvar] and [variable]) into a sequence of instructions ("bytecodes").
* Also includes the operator command compilers.
*
| | | | | | | | < < | < < | | < | | | | 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 |
/*
* tclCompCmdsSZ.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 's' through 'z', except for
* [upvar] and [variable]) into a sequence of instructions ("bytecodes").
* Also includes the operator command compilers.
*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-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.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclStringTrim.h"
/*
* Prototypes for procedures defined later in this file:
*/
static AuxDataDupProc DupJumptableInfo;
static AuxDataFreeProc FreeJumptableInfo;
static AuxDataPrintProc PrintJumptableInfo;
static AuxDataPrintProc DisassembleJumptableInfo;
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
static int CompileComparisonOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int instruction,
CompileEnv *envPtr);
static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int instruction,
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,
int numWords, Tcl_Token **bodyToken,
int *bodyLines, int **bodyNext);
static void IssueSwitchJumpTable(Tcl_Interp *interp,
CompileEnv *envPtr, int numWords,
Tcl_Token **bodyToken, int *bodyLines,
int **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,
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
*/
int
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
*/
int
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, localIndex, numWords;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
return TCL_ERROR;
}
isAssignment = (numWords == 3);
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
*/
int
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | | 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 |
*/
int
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
int i, numWords = parsePtr->numWords, numArgs;
Tcl_Token *wordTokenPtr;
Tcl_Obj *obj, *folded;
/* Trivial case, no arg */
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;
}
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
}
int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
}
int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
}
int
TclCompileStringEqualCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
}
int
TclCompileStringEqualCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
}
int
TclCompileStringFirstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
}
int
TclCompileStringFirstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
}
int
TclCompileStringLastCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
}
int
TclCompileStringLastCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
}
int
TclCompileStringIndexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
}
int
TclCompileStringIndexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
}
int
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | | 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 |
}
int
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
int idx;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
/* Compute and push the string in which to insert */
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
/* See what can be discovered about index at compile time */
tokenPtr = TokenAfter(tokenPtr);
if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START,
TCL_INDEX_END, &idx)) {
/* Nothing useful knowable - cease compile; let it direct eval */
return TCL_ERROR;
}
/* Compute and push the string to be inserted */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 3);
if (idx == (int)TCL_INDEX_START) {
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
"xdigit", NULL
};
| | | | 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 |
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
"xdigit", NULL
};
enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
STR_IS_XDIGIT
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
Tcl_Obj *isClass;
if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
return TCL_ERROR;
}
TclNewObj(isClass);
if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
Tcl_DecrRefCount(isClass);
return TCL_ERROR;
} else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
&t) != TCL_OK) {
Tcl_DecrRefCount(isClass);
TclCompileSyntaxError(interp, envPtr);
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
* 3. Integers
* 4. Floats
* 5. Lists
*/
CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
| | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
* 3. Integers
* 4. Floats
* 5. Lists
*/
CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
switch ((enum isClassesEnum) t) {
case STR_IS_ALNUM:
strClassType = STR_CLASS_ALNUM;
goto compileStrClass;
case STR_IS_ALPHA:
strClassType = STR_CLASS_ALPHA;
goto compileStrClass;
case STR_IS_ASCII:
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
}
int
TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
}
int
TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
Tcl_Obj *objPtr;
if (parsePtr->numWords != 2) {
|
| ︙ | ︙ | |||
940 941 942 943 944 945 946 |
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
| | | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
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 (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
}
int
TclCompileStringRangeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
}
int
TclCompileStringRangeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
}
int
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
}
int
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
/* Bytecode to compute/push string argument being replaced */
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
}
int
TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
}
int
TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 |
}
int
TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
}
int
TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
}
int
TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
}
int
TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
| | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
{"", NULL}
};
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
|
| ︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 |
*/
int
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | | | 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 |
*/
int
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
int numArgs = parsePtr->numWords - 1;
int numOpts = numArgs - 1;
int objc, flags = TCL_SUBST_ALL;
Tcl_Obj **objv/*, *toSubst = NULL*/;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
int code = TCL_ERROR;
if (numArgs == 0) {
return TCL_ERROR;
}
objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
TclNewObj(objv[objc]);
Tcl_IncrRefCount(objv[objc]);
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
objc++;
goto cleanup;
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
|
| ︙ | ︙ | |||
1791 1792 1793 1794 1795 1796 1797 |
*/
int
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
int
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr; /* Pointer to tokens in command. */
int numWords; /* Number of words in command. */
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
/* What kind of switch are we doing? */
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
int *bodyLines; /* Array of line numbers for body list
* items. */
int **bodyContLines; /* Array of continuation line info. */
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int i, valueIndex;
int result = TCL_ERROR;
int *clNext = envPtr->clNext;
/*
* Only handle the following versions:
* switch ?--? word {pattern body ...}
* switch -exact ?--? word {pattern body ...}
* switch -glob ?--? word {pattern body ...}
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
numBytes = tokenPtr[1].size;
/* Allocate enough space to work in. */
maxLen = TclMaxListLength(bytes, numBytes, NULL);
if (maxLen < 2) {
return TCL_ERROR;
}
| | | | | | 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
numBytes = tokenPtr[1].size;
/* Allocate enough space to work in. */
maxLen = TclMaxListLength(bytes, numBytes, NULL);
if (maxLen < 2) {
return TCL_ERROR;
}
bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen);
bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen);
bodyLines = (int *)ckalloc(sizeof(int) * maxLen);
bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen);
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
numWords = 0;
while (numBytes > 0) {
const char *prevBytes = bytes;
int literal;
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 |
return TCL_ERROR;
} else {
/*
* Multi-word definition of patterns & actions.
*/
| | | | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
return TCL_ERROR;
} else {
/*
* Multi-word definition of patterns & actions.
*/
bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords);
bodyLines = (int *)ckalloc(sizeof(int) * numWords);
bodyContLines = (int **)ckalloc(sizeof(int*) * numWords);
bodyTokenArray = NULL;
for (i=0 ; i<numWords ; i++) {
/*
* We only handle the very simplest case. Anything more complex is
* a good reason to go to the interpreted case anyway due to
* traces, etc.
*/
|
| ︙ | ︙ | |||
2077 2078 2079 2080 2081 2082 2083 |
* but it handles the most common case well enough.
*/
/* Both methods push the value to match against onto the stack. */
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
| | | | 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 |
* but it handles the most common case well enough.
*/
/* Both methods push the value to match against onto the stack. */
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken,
bodyLines, bodyContLines);
} else {
IssueSwitchChainedTests(interp, envPtr, mode, noCase,
numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
/*
* Clean up all our temporary space and return.
*/
|
| ︙ | ︙ | |||
2121 2122 2123 2124 2125 2126 2127 |
static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
| < | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 |
static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
|
| ︙ | ︙ | |||
2151 2152 2153 2154 2155 2156 2157 |
/*
* Generate a test for each arm.
*/
contFixIndex = -1;
contFixCount = 0;
| | | | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 |
/*
* Generate a test for each arm.
*/
contFixIndex = -1;
contFixCount = 0;
fixupArray = (JumpFixup *)TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
fixupTargetArray = (unsigned int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens);
memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
fixupCount = 0;
foundDefault = 0;
for (i=0 ; i<numBodyTokens ; i+=2) {
nextArmFixupIndex = -1;
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
|
| ︙ | ︙ | |||
2370 2371 2372 2373 2374 2375 2376 |
*----------------------------------------------------------------------
*/
static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
| < | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 |
*----------------------------------------------------------------------
*/
static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
|
| ︙ | ︙ | |||
2395 2396 2397 2398 2399 2400 2401 |
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
* table itself is independent of any invokation of the bytecode, and as
* such is stored in an auxData block.
*
* Start by allocating the jump table itself, plus some workspace.
*/
| | | | 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 |
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
* table itself is independent of any invokation of the bytecode, and as
* such is stored in an auxData block.
*
* Start by allocating the jump table itself, plus some workspace.
*/
jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
/*
* Next, issue the instruction to do the jump, together with what we want
* to do if things do not work out (jump to either the default clause or
* the "default" default, which just sets the result to empty). Note that
|
| ︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 |
*----------------------------------------------------------------------
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
| | | | | | | | | | | | > | | | 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 |
*----------------------------------------------------------------------
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
while (hPtr != NULL) {
newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
}
return newJtPtr;
}
static void
FreeJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree(jtPtr);
}
static void
PrintJumptableInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
unsigned int pcOffset)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
int offset, i = 0;
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));
if (i++) {
Tcl_AppendToObj(appendObj, ", ", -1);
if (i%4==0) {
Tcl_AppendToObj(appendObj, "\n\t\t", -1);
}
}
Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
keyPtr, pcOffset + offset);
}
}
static void
DisassembleJumptableInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_Obj *mapping;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
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));
Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
Tcl_NewWideIntObj(offset));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2668 2669 2670 2671 2672 2673 2674 |
*/
int
TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
*/
int
TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 256
|
| ︙ | ︙ | |||
2715 2716 2717 2718 2719 2720 2721 |
*/
int
TclCompileThrowCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 |
*/
int
TclCompileThrowCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
int codeKnown, codeIsList, codeIsValid, len;
|
| ︙ | ︙ | |||
2819 2820 2821 2822 2823 2824 2825 |
*/
int
TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 |
*/
int
TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
Tcl_Token *bodyToken, *finallyToken, *tokenPtr;
Tcl_Token **handlerTokens = NULL;
Tcl_Obj **matchClauses = NULL;
int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL;
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 |
/*
* Extract information about what handlers there are.
*/
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
| | | | | | | 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
/*
* Extract information about what handlers there are.
*/
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
handlerTokens = (Tcl_Token**)TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
matchClauses = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
int objc;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedToCompile;
|
| ︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
* For us to be here, there must be at least one handler.
*
* Slight overallocation, but reduces size of this function.
*/
| | | | | 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
* For us to be here, there must be at least one handler.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
noError = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
noError[i] = -1;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
|
| ︙ | ︙ | |||
3151 3152 3153 3154 3155 3156 3157 |
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
| | | 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 |
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
/*
* There is no finally clause, so we can avoid wrapping a catch
* context around the handler. That simplifies what instructions need
* to be issued a lot since we can let errors just fall through.
|
| ︙ | ︙ | |||
3333 3334 3335 3336 3337 3338 3339 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
*
* Slight overallocation, but reduces size of this function.
*/
| | | | 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
int noTrapError, trapError;
const char *p;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
|
| ︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 |
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
| | | 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 |
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
/*
* There is a finally clause, so we need a fairly complex sequence of
* instructions to deal with an on/trap handler because we must call
* the finally handler *and* we need to substitute the result from a
|
| ︙ | ︙ | |||
3629 3630 3631 3632 3633 3634 3635 |
*/
int
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | > | 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 |
*/
int
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
/* TODO: Consider support for compiling expanded args. */
/*
* Verify that all words - except the first non-option one - are known at
* compile time so that we can handle them without needing to do a nasty
* push/rotate. [Bug 3970f54c4e]
*/
for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
Tcl_Obj *leadingWord;
TclNewObj(leadingWord);
varTokenPtr = TokenAfter(varTokenPtr);
if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
TclDecrRefCount(leadingWord);
/*
* We can tolerate non-trivial substitutions in the first variable
* to be unset. If a '--' or '-nocomplain' was present, anything
|
| ︙ | ︙ | |||
3767 3768 3769 3770 3771 3772 3773 |
*/
int
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 |
*/
int
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the while
|
| ︙ | ︙ | |||
3945 3946 3947 3948 3949 3950 3951 |
*/
int
TclCompileYieldCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 |
*/
int
TclCompileYieldCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
return TCL_ERROR;
}
if (parsePtr->numWords == 1) {
|
| ︙ | ︙ | |||
3988 3989 3990 3991 3992 3993 3994 |
*/
int
TclCompileYieldToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 |
*/
int
TclCompileYieldToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
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 *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int i;
if (parsePtr->numWords < 2) {
|
| ︙ | ︙ | |||
4035 4036 4037 4038 4039 4040 4041 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode(instruction, envPtr);
|
| ︙ | ︙ | |||
4077 4078 4079 4080 4081 4082 4083 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
| < > | 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
|
| ︙ | ︙ | |||
4162 4163 4164 4165 4166 4167 4168 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
4238 4239 4240 4241 4242 4243 4244 |
*----------------------------------------------------------------------
*/
int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
| | < | < | < | < | < | < | < | < > > > > < < < < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < < > | 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 |
*----------------------------------------------------------------------
*/
int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
}
int
TclCompileNotOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
}
int
TclCompileAddOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
envPtr);
}
int
TclCompileMulOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
envPtr);
}
int
TclCompileAndOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
envPtr);
}
int
TclCompileOrOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
envPtr);
}
int
TclCompileXorOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
envPtr);
}
int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
PUSH("1");
words++;
}
while (--words > 1) {
TclEmitOpcode(INST_EXPON, envPtr);
}
return TCL_OK;
}
int
TclCompileLshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
}
int
TclCompileRshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
}
int
TclCompileModOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
}
int
TclCompileNeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
}
int
TclCompileStrneqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
}
int
TclCompileInOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
}
int
TclCompileNiOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
envPtr);
}
int
TclCompileLessOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
}
int
TclCompileLeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
}
int
TclCompileGreaterOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
}
int
TclCompileGeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
}
int
TclCompileEqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
}
int
TclCompileStreqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
int
TclCompileStrLtOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr);
}
int
TclCompileStrLeOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr);
}
int
TclCompileStrGtOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr);
}
int
TclCompileStrGeOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr);
}
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ | |||
4585 4586 4587 4588 4589 4590 4591 |
return TCL_OK;
}
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
| | < < > | 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 |
return TCL_OK;
}
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
160 161 162 163 164 165 166 167 168 169 170 171 172 173 | #define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to * FUNCTION or a parse error according to * context and value. */ #define INCOMPLETE 4 /* A parse error. Used only when the single * "=" is encountered. */ #define INVALID 5 /* A parse error. Used when any punctuation * appears that's not a supported operator. */ /* Leaf lexemes */ #define NUMBER (LEAF | 1) /* For literal numbers */ #define SCRIPT (LEAF | 2) /* Script substitution; [foo] */ | > > | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | #define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to * FUNCTION or a parse error according to * context and value. */ #define INCOMPLETE 4 /* A parse error. Used only when the single * "=" is encountered. */ #define INVALID 5 /* A parse error. Used when any punctuation * appears that's not a supported operator. */ #define COMMENT 6 /* Comment. Lasts to end of line or end of * expression, whichever comes first. */ /* Leaf lexemes */ #define NUMBER (LEAF | 1) /* For literal numbers */ #define SCRIPT (LEAF | 2) /* Script substitution; [foo] */ |
| ︙ | ︙ | |||
458 459 460 461 462 463 464 | INVALID /* DC4 */, INVALID /* NAK */, INVALID /* SYN */, INVALID /* ETB */, INVALID /* CAN */, INVALID /* EM */, INVALID /* SUB */, INVALID /* ESC */, INVALID /* FS */, INVALID /* GS */, INVALID /* RS */, INVALID /* US */, INVALID /* SPACE */, 0 /* ! or != */, | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | INVALID /* DC4 */, INVALID /* NAK */, INVALID /* SYN */, INVALID /* ETB */, INVALID /* CAN */, INVALID /* EM */, INVALID /* SUB */, INVALID /* ESC */, INVALID /* FS */, INVALID /* GS */, INVALID /* RS */, INVALID /* US */, INVALID /* SPACE */, 0 /* ! or != */, QUOTED /* " */, 0 /* # */, VARIABLE /* $ */, MOD /* % */, 0 /* & or && */, INVALID /* ' */, OPEN_PAREN /* ( */, CLOSE_PAREN /* ) */, 0 /* * or ** */, PLUS /* + */, COMMA /* , */, MINUS /* - */, 0 /* . */, DIVIDE /* / */, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0-9 */ |
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
* constructed out of substrings of the
* original expression. In order to keep the
* error message readable, we impose this
* limit on the substring size we extract. */
TclParseInit(interp, start, numBytes, parsePtr);
| | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
* constructed out of substrings of the
* original expression. In order to keep the
* error message readable, we impose this
* limit on the substring size we extract. */
TclParseInit(interp, start, numBytes, parsePtr);
nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
errCode = "NOMEM";
goto error;
}
/*
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
*/
if (nodesUsed >= nodesAvailable) {
unsigned int size = nodesUsed * 2;
OpNode *newPtr = NULL;
do {
| | > | | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
*/
if (nodesUsed >= nodesAvailable) {
unsigned int size = nodesUsed * 2;
OpNode *newPtr = NULL;
do {
if (size <= UINT_MAX/sizeof(OpNode)) {
newPtr = (OpNode *) attemptckrealloc(nodes,
size * sizeof(OpNode));
}
} while ((newPtr == NULL)
&& ((size -= (size - nodesUsed) / 2) > nodesUsed));
if (newPtr == NULL) {
TclNewLiteralStringObj(msg,
"not enough memory to parse expression");
errCode = "NOMEM";
goto error;
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 711 712 713 714 715 716 717 |
* Use context to categorize the lexemes that are ambiguous.
*/
if ((NODE_TYPE & lexeme) == 0) {
int b;
switch (lexeme) {
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
scanned, start);
errCode = "BADCHAR";
goto error;
case INCOMPLETE:
msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"",
| > > > > | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
* Use context to categorize the lexemes that are ambiguous.
*/
if ((NODE_TYPE & lexeme) == 0) {
int b;
switch (lexeme) {
case COMMENT:
start += scanned;
numBytes -= scanned;
continue;
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
scanned, start);
errCode = "BADCHAR";
goto error;
case INCOMPLETE:
msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"",
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
* 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 = BOOLEAN;
} else {
Tcl_DecrRefCount(literal);
msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
(scanned < limit) ? scanned : limit - 3, start,
(scanned < limit) ? "" : "...");
post = Tcl_ObjPrintf(
"should be \"$%.*s%s\" or \"{%.*s%s}\"",
(scanned < limit) ? scanned : limit - 3,
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
* 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 = BOOLEAN;
} else {
/*
* Tricky case: see test expr-62.10
*/
int scanned2 = scanned;
do {
scanned2 += TclParseAllWhiteSpace(
start + scanned2, numBytes - scanned2);
scanned2 += ParseLexeme(
start + scanned2, numBytes - scanned2, &lexeme,
NULL);
} while (lexeme == COMMENT);
if (lexeme == OPEN_PAREN) {
/*
* Actually a function call, but with obscuring
* comments. Skip to the start of the parentheses.
* Note that we assume that open parentheses are one
* byte long.
*/
lexeme = FUNCTION;
Tcl_ListObjAppendElement(NULL, funcList, literal);
scanned = scanned2 - 1;
break;
}
Tcl_DecrRefCount(literal);
msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
(scanned < limit) ? scanned : limit - 3, start,
(scanned < limit) ? "" : "...");
post = Tcl_ObjPrintf(
"should be \"$%.*s%s\" or \"{%.*s%s}\"",
(scanned < limit) ? scanned : limit - 3,
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
errCode = "BADCHAR";
goto error;
}
scanned = tokenPtr->size;
break;
case SCRIPT: {
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
errCode = "BADCHAR";
goto error;
}
scanned = tokenPtr->size;
break;
case SCRIPT: {
Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
tokenPtr->type = TCL_TOKEN_COMMAND;
tokenPtr->start = start;
tokenPtr->numComponents = 0;
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 | * * On the contrary, if the end goal of this parse is to fill a * Tcl_Parse for a caller of Tcl_ParseExpr(), then it's * wasteful to convert to a literal only to convert back again * later. */ | | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 |
*
* On the contrary, if the end goal of this parse is to fill a
* Tcl_Parse for a caller of Tcl_ParseExpr(), then it's
* wasteful to convert to a literal only to convert back again
* later.
*/
TclNewObj(literal);
if (TclWordKnownAtCompileTime(tokenPtr, literal)) {
Tcl_ListObjAppendElement(NULL, litList, literal);
complete = lastParsed = OT_LITERAL;
parsePtr->numTokens = wordIndex;
break;
}
Tcl_DecrRefCount(literal);
|
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
* first null character. */
Tcl_Parse *parsePtr) /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is ignored. */
{
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
| | | | > > | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
* first null character. */
Tcl_Parse *parsePtr) /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is ignored. */
{
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList; /* List to hold the literals. */
Tcl_Obj *funcList; /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
TclNewObj(litList);
TclNewObj(funcList);
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
}
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
|
| ︙ | ︙ | |||
1888 1889 1890 1891 1892 1893 1894 |
int 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;
| | | > > > > > > > > > > | 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 |
int 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 scanned, size;
int ch;
Tcl_Obj *literal = NULL;
unsigned char byte;
if (numBytes == 0) {
*lexemePtr = END;
return 0;
}
byte = UCHAR(*start);
if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) {
*lexemePtr = Lexeme[byte];
return 1;
}
switch (byte) {
case '#':
/*
* Scan forward over the comment contents.
*/
for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) {
byte = UCHAR(start[size]);
}
*lexemePtr = COMMENT;
return size - (byte == '\n');
case '*':
if ((numBytes > 1) && (start[1] == '*')) {
*lexemePtr = EXPON;
return 2;
}
*lexemePtr = MULT;
return 1;
|
| ︙ | ︙ | |||
2036 2037 2038 2039 2040 2041 2042 |
*lexemePtr = STR_GEQ;
return 2;
}
}
break;
}
| | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
*lexemePtr = STR_GEQ;
return 2;
}
}
break;
}
TclNewObj(literal);
if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end,
TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
if (end < start + numBytes && !TclIsBareword(*end)) {
number:
TclInitStringRep(literal, start, end-start);
*lexemePtr = NUMBER;
|
| ︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 |
/*
* We reject leading underscores in bareword. No sensible reason why.
* Might be inspired by reserved identifier rules in C, which of course
* have no direct relevance here.
*/
if (!TclIsBareword(*start) || *start == '_') {
| | | | | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
/*
* We reject leading underscores in bareword. No sensible reason why.
* Might be inspired by reserved identifier rules in C, which of course
* have no direct relevance here.
*/
if (!TclIsBareword(*start) || *start == '_') {
if (TclUCS4Complete(start, numBytes)) {
scanned = TclUtfToUCS4(start, &ch);
} else {
char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
scanned = TclUtfToUCS4(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
return scanned;
}
end = start;
while (numBytes && TclIsBareword(*end)) {
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
Tcl_Interp *interp, /* Used for error reporting. */
const char *script, /* The source script to compile. */
int numBytes, /* Number of bytes in script. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
| | | | > > > | | 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 |
Tcl_Interp *interp, /* Used for error reporting. */
const char *script, /* The source script to compile. */
int numBytes, /* Number of bytes in script. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int optimize) /* 0 for one-off expressions. */
{
OpNode *opTree = NULL; /* Will point to the tree of operators */
Tcl_Obj *litList; /* List to hold the literals */
Tcl_Obj *funcList; /* List to hold the functon names*/
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code;
TclNewObj(litList);
TclNewObj(funcList);
code = ParseExpr(interp, script, numBytes, &opTree, litList,
funcList, parsePtr, 0 /* parseOnly */);
if (code == TCL_OK) {
/*
* Valid parse; compile the tree.
*/
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 |
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
* bytecode, so there's no need to tend to TIP 280 issues.
*/
| | | 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 |
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
* bytecode, so there's no need to tend to TIP 280 issues.
*/
envPtr = (CompileEnv *)TclStackAlloc(interp, sizeof(CompileEnv));
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
TclEmitOpcode(INST_DONE, envPtr);
byteCodePtr = TclInitByteCode(envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 | */ nodePtr->left = numWords; numWords = 2; /* Command plus one argument */ break; } case QUESTION: | | | | | 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 |
*/
nodePtr->left = numWords;
numWords = 2; /* Command plus one argument */
break;
}
case QUESTION:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpPtr->jump);
TclAdjustStackDepth(-1, envPtr);
if (convert) {
jumpPtr->jump.jumpType = TCL_TRUE_JUMP;
}
convert = 1;
break;
case AND:
case OR:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump);
break;
}
} else {
|
| ︙ | ︙ | |||
2454 2455 2456 2457 2458 2459 2460 |
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
| | | | | 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 |
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
int 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:
*
* lePtr->objPtr = literal;
* Tcl_IncrRefCount(literal);
* Tcl_DecrRefCount(objPtr);
*
* However, the design of the "global" and "local"
* LiteralTable does not permit the value of lePtr->objPtr
* to change. So rather than replace lePtr->objPtr, we do
* surgery to transfer our desired intrep into it.
*/
objPtr->typePtr = literal->typePtr;
objPtr->internalRep = literal->internalRep;
literal->typePtr = NULL;
}
TclEmitPush(idx, envPtr);
} else {
/*
* When optimize==0, we know the expression is a one-off and
* there's nothing to be gained from sharing literals when
* they won't live long, and the copies we have already have
* an appropriate intrep. In this case, skip literal
* registration that would enable sharing, and use the routine
|
| ︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 |
break;
default:
if (optimize && nodes[next].constant) {
Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK);
if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
== TCL_OK) {
| | | | | | | 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 |
break;
default:
if (optimize && nodes[next].constant) {
Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK);
if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
== TCL_OK) {
int idx;
Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
/*
* Don't generate a string rep, but if we have one
* already, then use it to share via the literal table.
*/
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
int numBytes;
const char *bytes
= Tcl_GetStringFromObj(objPtr, &numBytes);
idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
* Same intrep surgery as for OT_LITERAL.
*/
tableValue->typePtr = objPtr->typePtr;
tableValue->internalRep = objPtr->internalRep;
objPtr->typePtr = NULL;
}
} else {
idx = TclAddLiteralObj(envPtr, objPtr, NULL);
}
TclEmitPush(idx, envPtr);
} else {
TclCompileSyntaxError(interp, envPtr);
}
Tcl_RestoreInterpState(interp, save);
convert = 0;
} else {
nodePtr = nodes + next;
|
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 |
int
TclSingleOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 |
int
TclSingleOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
OpNode nodes[2];
Tcl_Obj *const *litObjv = objv + 1;
if (objc != 1 + occdPtr->i.numArgs) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 |
Tcl_Obj *const objv[])
{
int code = TCL_OK;
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
| | | | | 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
Tcl_Obj *const objv[])
{
int code = TCL_OK;
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
Tcl_Obj **litObjv = (Tcl_Obj **)TclStackAlloc(interp,
2 * (objc-2) * sizeof(Tcl_Obj *));
OpNode *nodes = (OpNode *)TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
unsigned char lexeme;
int i, lastAnd = 1;
Tcl_Obj *const *litObjPtrPtr = litObjv;
ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
litObjv[0] = objv[1];
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
int
TclVariadicOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | | | | | 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 |
int
TclVariadicOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity));
return TCL_OK;
}
ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
lexeme |= BINARY;
if (objc == 2) {
Tcl_Obj *litObjv[2];
OpNode nodes[2];
int decrMe = 0;
Tcl_Obj *const *litObjPtrPtr = litObjv;
if (lexeme == EXPON) {
TclNewIntObj(litObjv[1], occdPtr->i.identity);
Tcl_IncrRefCount(litObjv[1]);
decrMe = 1;
litObjv[0] = objv[1];
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
nodes[0].right = 1;
nodes[1].lexeme = lexeme;
nodes[1].mark = MARK_LEFT;
nodes[1].left = OT_LITERAL;
nodes[1].right = OT_LITERAL;
nodes[1].p.parent = 0;
} else {
if (lexeme == DIVIDE) {
litObjv[0] = Tcl_NewDoubleObj(1.0);
} else {
TclNewIntObj(litObjv[0], occdPtr->i.identity);
}
Tcl_IncrRefCount(litObjv[0]);
litObjv[1] = objv[1];
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
nodes[0].right = 1;
nodes[1].lexeme = lexeme;
nodes[1].mark = MARK_LEFT;
nodes[1].left = OT_LITERAL;
nodes[1].right = OT_LITERAL;
nodes[1].p.parent = 0;
}
code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
Tcl_DecrRefCount(litObjv[decrMe]);
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
int i, lastOp = OT_LITERAL;
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
if (lexeme == EXPON) {
for (i=objc-2; i>0; i--) {
nodes[i].lexeme = lexeme;
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 |
int
TclNoIdentOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
int
TclNoIdentOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
return TCL_ERROR;
}
return TclVariadicOpCmd(clientData, interp, objc, objv);
}
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
1 2 3 4 5 6 7 |
/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts of
* commands (like quoted strings or nested sub-commands) into a sequence
* of instructions ("bytecodes").
*
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts of
* commands (like quoted strings or nested sub-commands) into a sequence
* of instructions ("bytecodes").
*
* Copyright © 1996-1998 Sun Microsystems, Inc.
* Copyright © 2001 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 "tclCompile.h"
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 | static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); | | < | | 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 | static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(CompileEnv *envPtr); static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. |
| ︙ | ︙ | |||
845 846 847 848 849 850 851 |
* Check for optimizations!
*
* Test if the generated code is free of most hazards; if so, recompile
* but with generation of INST_START_CMD disabled. This produces somewhat
* faster code in some cases, and more compact code in more.
*/
| | | | 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 |
* Check for optimizations!
*
* Test if the generated code is free of most hazards; if so, recompile
* but with generation of INST_START_CMD disabled. This produces somewhat
* faster code in some cases, and more compact code in more.
*/
if (Tcl_GetParent(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
&& IsCompactibleCompileEnv(&compEnv)) {
TclFreeCompileEnv(&compEnv);
iPtr->compiledProcPtr = procPtr;
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
if (clLocPtr) {
compEnv.clNext = &clLocPtr->loc[0];
}
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 | * None. * *---------------------------------------------------------------------- */ static void DupByteCodeInternalRep( | | | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
* None.
*
*----------------------------------------------------------------------
*/
static void
DupByteCodeInternalRep(
TCL_UNUSED(Tcl_Obj *) /*srcPtr*/,
TCL_UNUSED(Tcl_Obj *) /*copyPtr*/)
{
return;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
(char *) codePtr);
if (hePtr) {
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
(char *) codePtr);
if (hePtr) {
ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 | * piece of bytecode. Idempotent. * * --------------------------------------------------------------------- */ static int IsCompactibleCompileEnv( | < | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
* piece of bytecode. Idempotent.
*
* ---------------------------------------------------------------------
*/
static int
IsCompactibleCompileEnv(
CompileEnv *envPtr)
{
unsigned char *pc;
int size;
/*
* Special: procedures in the '::tcl' namespace (or its children) are
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
| | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
if (invoker == NULL) {
/*
|
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | /* * Initialize the compiler using the context, making counting absolute * to that context. Note that the context can be byte code execution. * In that case we have to fill out the missing pieces (line, path, * ...) which may make change the type as well. */ | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 |
/*
* Initialize the compiler using the context, making counting absolute
* to that context. Note that the context can be byte code execution.
* In that case we have to fill out the missing pieces (line, path,
* ...) which may make change the type as well.
*/
CmdFrame *ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
int pc = 0;
*ctxPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
|
| ︙ | ︙ | |||
1744 1745 1746 1747 1748 1749 1750 |
return 1;
}
if (tokenPtr->type != TCL_TOKEN_WORD) {
return 0;
}
tokenPtr++;
if (valuePtr != NULL) {
| | | 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
return 1;
}
if (tokenPtr->type != TCL_TOKEN_WORD) {
return 0;
}
tokenPtr++;
if (valuePtr != NULL) {
TclNewObj(tempPtr);
Tcl_IncrRefCount(tempPtr);
}
while (numComponents--) {
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
if (tempPtr != NULL) {
Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
|
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &numBytes);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
| | < > | 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 |
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &numBytes);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
void
TclCompileInvocation(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
int wordIdx = 0, depth = TclGetStackDepth(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
}
|
| ︙ | ︙ | |||
1890 1891 1892 1893 1894 1895 1896 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
| < > | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
int wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
StartExpanding(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
| < > | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
DefineLineInformation;
int unwind = 0, incrOffset = -1;
int depth = TclGetStackDepth(envPtr);
/*
* Emit of the INST_START_CMD instruction is controlled by the value of
* envPtr->atCmdStart:
*
* atCmdStart == 2 : We are not using the INST_START_CMD instruction.
|
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
Interp *iPtr = (Interp *) interp;
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
| | > | | 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 |
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
Interp *iPtr = (Interp *) interp;
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
Tcl_Obj *cmdObj;
Command *cmdPtr = NULL;
int code = TCL_ERROR;
int cmdKnown, expand = -1;
int *wlines, wlineat;
int cmdLine = envPtr->line;
int *clNext = envPtr->clNext;
int cmdIdx = envPtr->numCommands;
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
assert (parsePtr->numWords > 0);
/* Pre-Compile */
TclNewObj(cmdObj);
envPtr->numCommands++;
EnterCmdStartData(envPtr, cmdIdx,
parsePtr->commandStart - envPtr->source, startCodeOffset);
/*
* TIP #280. Scan the words and compute the extended location information.
* The map first contain full per-word line information for use by the
* compiler. This is later replaced by a reduced form which signals
* non-literal words, stored in 'wlines'.
*/
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
parsePtr->tokenPtr, parsePtr->commandStart,
parsePtr->numWords, cmdLine,
clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
envPtr->line = eclPtr->loc[wlineat].line[0];
envPtr->clNext = eclPtr->loc[wlineat].next[0];
/* Do we know the command word? */
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
if (numBytes > 0) {
/*
* 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].
*/
| | | 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 |
if (numBytes > 0) {
/*
* 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 *)ckalloc(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.
|
| ︙ | ︙ | |||
2441 2442 2443 2444 2445 2446 2447 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
|
| ︙ | ︙ | |||
2482 2483 2484 2485 2486 2487 2488 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
| | | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
*/
int
TclCompileNoOp(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 |
*/
int
TclCompileNoOp(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
tokenPtr = parsePtr->tokenPtr;
for (i = 1; i < parsePtr->numWords; i++) {
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
| | | 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
p = (unsigned char *)ckalloc(structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
codePtr->refCount = 0;
TclPreserveByteCode(codePtr);
|
| ︙ | ︙ | |||
3069 3070 3071 3072 3073 3074 3075 |
/*
* Create a new variable if appropriate.
*/
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
| | | 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 |
/*
* Create a new variable if appropriate.
*/
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + nameBytes + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
3119 3120 3121 3122 3123 3124 3125 |
*/
void
TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
| | | | | 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 |
*/
void
TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
CompileEnv *envPtr = (CompileEnv *)envArgPtr;
/* The CompileEnv containing the code array to
* be doubled in size. */
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
* code bytes are stored between envPtr->codeStart and envPtr->codeNext-1
* [inclusive].
*/
size_t currBytes = envPtr->codeNext - envPtr->codeStart;
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes);
} else {
/*
* envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
envPtr->mallocedCodeArray = 1;
}
envPtr->codeNext = envPtr->codeStart + currBytes;
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
| | | | 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
* envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes);
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
envPtr->mallocedCmdMap = 1;
}
envPtr->cmdMapEnd = newElems;
}
|
| ︙ | ︙ | |||
3304 3305 3306 3307 3308 3309 3310 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
| < | 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 |
EnterCmdWordData(
ExtCmdLoc *eclPtr, /* Points to the map environment structure in
* which to enter command location
* information. */
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
int numWords,
int line,
int *clNext,
int **wlines,
CompileEnv *envPtr)
{
ECL *ePtr;
|
| ︙ | ︙ | |||
3326 3327 3328 3329 3330 3331 3332 | * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); | | | | | | 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 |
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
size_t currElems = eclPtr->nloc;
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
ePtr->line = (int *)ckalloc(numWords * sizeof(int));
ePtr->next = (int **)ckalloc(numWords * sizeof(int *));
ePtr->nline = numWords;
wwlines = (int *)ckalloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
wordNext = clNext;
for (wordIdx=0 ; wordIdx<numWords;
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
TclAdvanceLines(&wordLine, last, tokenPtr->start);
|
| ︙ | ︙ | |||
3404 3405 3406 3407 3408 3409 3410 |
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
| | | | | | 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 |
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
(ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
(ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes);
ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
envPtr->exceptArrayPtr = newPtr;
envPtr->exceptAuxArrayPtr = newPtr2;
envPtr->mallocedExceptArray = 1;
}
|
| ︙ | ︙ | |||
3517 3518 3519 3520 3521 3522 3523 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
| | | | 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets,
sizeof(int) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
(unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
void
|
| ︙ | ︙ | |||
3543 3544 3545 3546 3547 3548 3549 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
| | | | 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets,
sizeof(int) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
(unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
|
| ︙ | ︙ | |||
3770 3771 3772 3773 3774 3775 3776 |
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
| | | | 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 |
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
(AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
AuxData *newPtr = (AuxData *)ckalloc(newBytes);
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayEnd = newElems;
}
|
| ︙ | ︙ | |||
3859 3860 3861 3862 3863 3864 3865 |
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
| | | | 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 |
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes);
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
fixupArrayPtr->mallocedArray = 1;
}
fixupArrayPtr->end = newElems;
}
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
923 924 925 926 927 928 929 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
| | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
char name[8]; /* Name of the class. */
int (*comparator)(int); /* Function to test if a single unicode
* character is a member of the class. */
} StringClassDesc;
MODULE_SCOPE StringClassDesc const tclStringClassTable[];
/*
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
* 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 {
int numVars; /* The number of variables in the list. */
| | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
* 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 {
int numVars; /* The number of variables in the list. */
int 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;
|
| ︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 |
* lists of the foreach command. */
int firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
int 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. */
| | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 |
* lists of the foreach command. */
int firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
int 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;
/*
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 |
* 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 {
int length; /* Size of array */
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
* 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 {
int length; /* Size of array */
int 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;
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
1 2 3 4 5 6 | /* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. * * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
char *encoding;
} QCCD;
/*
* Static functions in this file:
*/
| | < < | > < < | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
char *encoding;
} QCCD;
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc QueryConfigObjCmd;
static Tcl_CmdDeleteProc QueryConfigDelete;
static Tcl_InterpDeleteProc ConfigDictDeleteProc;
static Tcl_Obj * GetConfigDict(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
* Tcl_RegisterConfig --
*
* See TIP#59 for details on what this function does.
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
| | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
| | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
*-------------------------------------------------------------------------
*/
static void
QueryConfigDelete(
ClientData clientData)
{
| | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
*-------------------------------------------------------------------------
*/
static void
QueryConfigDelete(
ClientData clientData)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
ckfree(cdPtr->encoding);
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
Tcl_Obj *pDB = (Tcl_Obj *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
Tcl_IncrRefCount(pDB);
Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
}
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
| | < < | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclDate.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | /* * tclDate.c -- * * This file is generated from a yacc grammar defined in the file * tclGetDate.y. It should not be edited directly. * | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | /* * tclDate.c -- * * This file is generated from a yacc grammar defined in the file * tclGetDate.y. It should not be edited directly. * * Copyright (c) 1992-1995 Karl Lehenbauer & Mark Diekhans. * Copyright (c) 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" |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
| < < < | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_NULLPTR
# if defined __cplusplus && 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
| > > > | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_NULLPTR
# if defined __cplusplus && 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | # endif # endif #endif /* !YYCOPY_NEEDED */ /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ | | | | | 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 |
# endif
# endif
#endif /* !YYCOPY_NEEDED */
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
#define YYLAST 81
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 26
/* YYNNTS -- Number of nonterminals. */
#define YYNNTS 16
/* YYNRULES -- Number of rules. */
#define YYNRULES 56
/* YYNSTATES -- Number of states. */
#define YYNSTATES 85
/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned
by yylex, with out-of-bounds checking. */
#define YYUNDEFTOK 2
#define YYMAXUTOK 274
#define YYTRANSLATE(YYX) \
((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, without out-of-bounds checking. */
static const yytype_uint8 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, 25, 21, 23, 24, 22, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 20, 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,
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | > | | | | | | | | | | | | | | 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 |
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
245, 249, 254, 257, 263, 269, 277, 282, 287, 291,
297, 301, 305, 309, 313, 319, 323, 328, 333, 338,
343, 347, 352, 356, 361, 368, 372, 378, 388, 397,
406, 416, 430, 435, 438, 441, 444, 447, 450, 455,
458, 463, 467, 471, 477, 495, 498
};
#endif
#if YYDEBUG || YYERROR_VERBOSE || 0
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
"$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID",
"tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE", "tSEC_UNIT",
"tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", "tISOBASE",
"tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'", "'+'",
"$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth",
"iso", "trek", "relspec", "relunits", "sign", "unit", "number",
"o_merid", YY_NULLPTR
};
#endif
# ifdef YYPRINT
/* YYTOKNUM[NUM] -- (External) token number corresponding to the
(internal) symbol number NUM (which must be that of a token). */
static const yytype_uint16 yytoknum[] =
{
0, 256, 257, 258, 259, 260, 261, 262, 263, 264,
265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
58, 44, 47, 45, 46, 43
};
# endif
#define YYPACT_NINF -18
#define yypact_value_is_default(Yystate) \
(!!((Yystate) == (-18)))
#define YYTABLE_NINF -1
#define yytable_value_is_error(Yytable_value) \
0
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
static const yytype_int8 yypact[] =
{
-18, 2, -18, -17, -18, -4, -18, 10, -18, 22,
8, -18, 18, -18, 39, -18, -18, -18, -18, -18,
-18, -18, -18, -18, -18, -18, 25, 21, -18, -18,
-18, 16, 14, -18, -18, 28, 36, 41, -5, -18,
-18, 5, -18, -18, -18, 47, -18, -18, 42, 46,
48, -18, -6, 40, 43, 44, 49, -18, -18, -18,
-18, -18, -18, -18, -18, 50, -18, 51, 55, 57,
58, 65, -18, -18, 59, 54, -18, 62, 63, 60,
-18, 64, 61, 66, -18
};
/* 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_uint8 yydefact[] =
{
2, 0, 1, 20, 18, 0, 53, 0, 51, 54,
17, 33, 27, 52, 0, 49, 50, 3, 4, 5,
8, 6, 7, 10, 11, 9, 43, 0, 48, 12,
21, 30, 0, 22, 13, 32, 0, 0, 0, 45,
16, 0, 40, 24, 35, 0, 46, 42, 19, 0,
0, 34, 55, 25, 0, 0, 0, 38, 36, 47,
23, 44, 31, 41, 56, 0, 14, 0, 0, 0,
0, 55, 26, 28, 29, 0, 15, 0, 0, 0,
39, 0, 0, 0, 37
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-18, -18, -18, -18, -18, -18, -18, -18, -18, -18,
-18, -18, -18, -9, -18, 7
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int8 yydefgoto[] =
{
-1, 1, 17, 18, 19, 20, 21, 22, 23, 24,
25, 26, 27, 28, 29, 66
};
/* 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_uint8 yytable[] =
{
39, 64, 2, 54, 30, 46, 3, 4, 55, 31,
5, 6, 7, 8, 65, 9, 10, 11, 56, 12,
13, 14, 57, 32, 40, 15, 33, 16, 47, 34,
35, 6, 41, 8, 48, 42, 59, 49, 50, 61,
13, 51, 36, 43, 37, 38, 60, 44, 6, 52,
8, 6, 45, 8, 53, 58, 6, 13, 8, 62,
13, 63, 67, 71, 72, 13, 68, 69, 73, 70,
74, 75, 64, 77, 78, 79, 80, 82, 76, 84,
81, 83
};
static const yytype_uint8 yycheck[] =
{
9, 7, 0, 8, 21, 14, 4, 5, 13, 13,
8, 9, 10, 11, 20, 13, 14, 15, 13, 17,
18, 19, 17, 13, 16, 23, 4, 25, 3, 7,
8, 9, 14, 11, 13, 17, 45, 21, 24, 48,
18, 13, 20, 4, 22, 23, 4, 8, 9, 13,
11, 9, 13, 11, 13, 8, 9, 18, 11, 13,
18, 13, 22, 13, 13, 18, 23, 23, 13, 20,
13, 13, 7, 14, 20, 13, 13, 13, 71, 13,
20, 20
};
/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
symbol of state STATE-NUM. */
static const yytype_uint8 yystos[] =
{
0, 27, 0, 4, 5, 8, 9, 10, 11, 13,
14, 15, 17, 18, 19, 23, 25, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
21, 13, 13, 4, 7, 8, 20, 22, 23, 39,
16, 14, 17, 4, 8, 13, 39, 3, 13, 21,
24, 13, 13, 13, 8, 13, 13, 17, 8, 39,
4, 39, 13, 13, 7, 20, 41, 22, 23, 23,
20, 13, 13, 13, 13, 13, 41, 14, 20, 13,
13, 20, 13, 20, 13
};
/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
static const yytype_uint8 yyr1[] =
{
0, 26, 27, 27, 28, 28, 28, 28, 28, 28,
28, 28, 28, 29, 29, 29, 30, 30, 30, 30,
31, 31, 31, 31, 31, 32, 32, 32, 32, 32,
32, 32, 32, 32, 32, 33, 33, 34, 34, 34,
34, 35, 36, 36, 37, 37, 37, 37, 37, 38,
38, 39, 39, 39, 40, 41, 41
};
/* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */
static const yytype_uint8 yyr2[] =
{
0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1, 2, 4, 6, 2, 1, 1, 2,
1, 2, 2, 3, 2, 3, 5, 1, 5, 5,
2, 4, 2, 1, 3, 2, 3, 11, 3, 7,
2, 4, 2, 1, 3, 2, 2, 3, 1, 1,
1, 1, 1, 1, 1, 0, 1
};
#define yyerrok (yyerrstatus = 0)
#define yyclearin (yychar = YYEMPTY)
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15:
| < < < < < < < < < < < < < > > > > > > > > > > | | < < < < | | > | < | | | | | < < < < < < < < < | | | | | | | | | | | > > > > > > > > > > > > > > | | | 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 |
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15:
{
yyHour = (yyvsp[-5].Number);
yyMinutes = (yyvsp[-3].Number);
yySeconds = (yyvsp[-1].Number);
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 16:
{
yyTimezone = (yyvsp[-1].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
break;
case 17:
{
yyTimezone = (yyvsp[0].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
break;
case 18:
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
case 19:
{
yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
case 20:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 21:
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[-1].Number);
}
break;
case 22:
{
yyDayOrdinal = (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 23:
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 24:
{
yyDayOrdinal = 2;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 25:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 26:
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 27:
{
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 28:
{
yyDay = (yyvsp[-4].Number);
yyMonth = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 29:
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
yyYear = (yyvsp[-4].Number);
}
break;
case 30:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 31:
{
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 32:
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
case 33:
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
case 34:
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 35:
{
yyMonthOrdinal = 1;
yyMonth = (yyvsp[0].Number);
}
break;
case 36:
{
yyMonthOrdinal = (yyvsp[-1].Number);
yyMonth = (yyvsp[0].Number);
}
break;
case 37:
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-10].Number);
yyMonth = (yyvsp[-8].Number);
yyDay = (yyvsp[-6].Number);
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
break;
case 38:
{
if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-2].Number) / 10000;
yyMonth = ((yyvsp[-2].Number) % 10000)/100;
yyDay = (yyvsp[-2].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 39:
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-6].Number) / 10000;
yyMonth = ((yyvsp[-6].Number) % 10000)/100;
yyDay = (yyvsp[-6].Number) % 100;
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
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";
}
|
| ︙ | ︙ | |||
2677 2678 2679 2680 2681 2682 2683 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
2740 2741 2742 2743 2744 2745 2746 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
|
| ︙ | ︙ | |||
2783 2784 2785 2786 2787 2788 2789 |
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
| | | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 |
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
TclNewObj(dateInfo.messages);
dateInfo.separatrix = "";
Tcl_IncrRefCount(dateInfo.messages);
status = yyparse(&dateInfo);
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
|
| ︙ | ︙ | |||
2840 2841 2842 2843 2844 2845 2846 |
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
| | | | | | | | | 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 |
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
TclNewObj(result);
TclNewObj(resultElement);
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int)
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
}
TclNewObj(resultElement);
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) -yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
296 297 298 299 300 301 302 | /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags); /* 86 */ | | | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 | /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags); /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 89 */ |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | ClientData clientData); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ | | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 | ClientData clientData); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 97 */ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, int isSafe); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 99 */ EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); |
| ︙ | ︙ | |||
478 479 480 481 482 483 484 |
/* 146 */
EXTERN int Tcl_Flush(Tcl_Channel chan);
/* 147 */
TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult")
void Tcl_FreeResult(Tcl_Interp *interp);
/* 148 */
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
| | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
/* 146 */
EXTERN int Tcl_Flush(Tcl_Channel chan);
/* 147 */
TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult")
void Tcl_FreeResult(Tcl_Interp *interp);
/* 148 */
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
const char **targetCmdPtr, int *argcPtr,
const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
const char *name,
Tcl_InterpDeleteProc **procPtr);
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 | EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ | | | | | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp); /* 164 */ EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, |
| ︙ | ︙ | |||
552 553 554 555 556 557 558 | /* 169 */ EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ | | < | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
/* 169 */
EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
/* 170 */
EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 171 */
EXTERN int Tcl_GetServiceMode(void);
/* 172 */
EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name);
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
TCL_DEPRECATED("No longer in use, changed to macro")
const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
|
| ︙ | ︙ | |||
1202 1203 1204 1205 1206 1207 1208 | /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr); /* 401 */ | > | > | | 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 |
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr);
/* 401 */
TCL_DEPRECATED("Use Tcl_ChannelClose2Proc")
Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr);
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr);
/* 403 */
EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr);
/* 404 */
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr);
/* 405 */
TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc")
Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr);
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr);
/* 407 */
EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(
const Tcl_ChannelType *chanTypePtr);
|
| ︙ | ︙ | |||
2028 2029 2030 2031 2032 2033 2034 |
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
| | | | | 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 |
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */
Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */
void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */
void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */
void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */
int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
|
| ︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 |
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 */
TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
| | | | | | | 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 |
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 */
TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
ClientData (*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 */
int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */
ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */
Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 |
int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
| | | | 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 |
int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
TCL_DEPRECATED_API("Use Tcl_ChannelClose2Proc") Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */
Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */
Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */
TCL_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) (const Tcl_ChannelType *chanTypePtr); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) (const Tcl_ChannelType *chanTypePtr); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) (const Tcl_ChannelType *chanTypePtr); /* 411 */
int (*tcl_JoinThread) (Tcl_ThreadId threadId, int *result); /* 412 */
|
| ︙ | ︙ | |||
2819 2820 2821 2822 2823 2824 2825 | (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ #define Tcl_CreateMathFunc \ (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ | | | | 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 | (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ #define Tcl_CreateMathFunc \ (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #define Tcl_CreateChild \ (tclStubsPtr->tcl_CreateChild) /* 97 */ #define Tcl_CreateTimerHandler \ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #define Tcl_CreateTrace \ (tclStubsPtr->tcl_CreateTrace) /* 99 */ #define Tcl_DeleteAssocData \ (tclStubsPtr->tcl_DeleteAssocData) /* 100 */ #define Tcl_DeleteChannelHandler \ |
| ︙ | ︙ | |||
2953 2954 2955 2956 2957 2958 2959 | (tclStubsPtr->tcl_GetCommandName) /* 160 */ #define Tcl_GetErrno \ (tclStubsPtr->tcl_GetErrno) /* 161 */ #define Tcl_GetHostName \ (tclStubsPtr->tcl_GetHostName) /* 162 */ #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ | | | | | | 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 | (tclStubsPtr->tcl_GetCommandName) /* 160 */ #define Tcl_GetErrno \ (tclStubsPtr->tcl_GetErrno) /* 161 */ #define Tcl_GetHostName \ (tclStubsPtr->tcl_GetHostName) /* 162 */ #define Tcl_GetInterpPath \ (tclStubsPtr->tcl_GetInterpPath) /* 163 */ #define Tcl_GetParent \ (tclStubsPtr->tcl_GetParent) /* 164 */ #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* MACOSX */ #define Tcl_GetPathType \ (tclStubsPtr->tcl_GetPathType) /* 168 */ #define Tcl_Gets \ (tclStubsPtr->tcl_Gets) /* 169 */ #define Tcl_GetsObj \ (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetChild \ (tclStubsPtr->tcl_GetChild) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #define Tcl_GetStringResult \ (tclStubsPtr->tcl_GetStringResult) /* 174 */ #define Tcl_GetVar \ (tclStubsPtr->tcl_GetVar) /* 175 */ #define Tcl_GetVar2 \ |
| ︙ | ︙ | |||
4054 4055 4056 4057 4058 4059 4060 |
} while(0)
#undef Tcl_DiscardResult
#define Tcl_DiscardResult(statePtr) \
Tcl_DecrRefCount((statePtr)->objResultPtr)
#undef Tcl_SetResult
#define Tcl_SetResult(interp, result, freeProc) \
do { \
| | | | | 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 |
} while(0)
#undef Tcl_DiscardResult
#define Tcl_DiscardResult(statePtr) \
Tcl_DecrRefCount((statePtr)->objResultPtr)
#undef Tcl_SetResult
#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) { \
ckfree((char *)__result); \
} else { \
(*__freeProc)((char *)__result); \
} \
} \
} while(0)
#endif /* TCL_NO_DEPRECATED */
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
|
| ︙ | ︙ | |||
4166 4167 4168 4169 4170 4171 4172 4173 4174 |
#undef Tcl_EvalObj
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
#endif /* _TCLDECLS */
| > > > > > > > > > > > > > > | 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 |
#undef Tcl_EvalObj
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS)
#undef Tcl_Close
#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#endif
#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX > 3)
# undef Tcl_UtfCharComplete
# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length)))
#endif
#define Tcl_CreateSlave Tcl_CreateChild
#define Tcl_GetSlave Tcl_GetChild
#define Tcl_GetMaster Tcl_GetParent
#endif /* _TCLDECLS */
|
Changes to generic/tclDictObj.c.
1 2 3 4 5 6 | /* * tclDictObj.c -- * * This file contains functions that implement the Tcl dict object type * and its accessor command. * | | | | < | < | < | < | < | < | < | < | < | | | | | | | | | < < < < < < < < < | < | | | | | | | | | | | > | | | | | | | 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 |
/*
* tclDictObj.c --
*
* This file contains functions that implement the Tcl dict object type
* and its accessor command.
*
* Copyright © 2002-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.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include <assert.h>
/*
* Forward declaration.
*/
struct Dict;
/*
* Prototypes for functions defined later in this file:
*/
static void DeleteDict(struct Dict *dict);
static Tcl_ObjCmdProc DictAppendCmd;
static Tcl_ObjCmdProc DictCreateCmd;
static Tcl_ObjCmdProc DictExistsCmd;
static Tcl_ObjCmdProc DictFilterCmd;
static Tcl_ObjCmdProc DictGetCmd;
static Tcl_ObjCmdProc DictGetDefCmd;
static Tcl_ObjCmdProc DictIncrCmd;
static Tcl_ObjCmdProc DictInfoCmd;
static Tcl_ObjCmdProc DictKeysCmd;
static Tcl_ObjCmdProc DictLappendCmd;
static Tcl_ObjCmdProc DictMergeCmd;
static Tcl_ObjCmdProc DictRemoveCmd;
static Tcl_ObjCmdProc DictReplaceCmd;
static Tcl_ObjCmdProc DictSetCmd;
static Tcl_ObjCmdProc DictSizeCmd;
static Tcl_ObjCmdProc DictUnsetCmd;
static Tcl_ObjCmdProc DictUpdateCmd;
static Tcl_ObjCmdProc DictValuesCmd;
static Tcl_ObjCmdProc DictWithCmd;
static Tcl_DupInternalRepProc DupDictInternalRep;
static Tcl_FreeInternalRepProc FreeDictInternalRep;
static void InvalidateDictChain(Tcl_Obj *dictObj);
static Tcl_SetFromAnyProc SetDictFromAny;
static Tcl_UpdateStringProc UpdateStringOfDict;
static Tcl_AllocHashEntryProc AllocChainEntry;
static inline void InitChainTable(struct Dict *dict);
static inline void DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry * CreateChainEntry(struct Dict *dict,
Tcl_Obj *keyPtr, int *newPtr);
static inline int DeleteChainEntry(struct Dict *dict,
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 },
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetIntRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclDictType); \
| | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetIntRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((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.
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 | * Increments the reference count on the object. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocChainEntry( | | | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocChainEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr)
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
ChainEntry *cPtr;
cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry));
cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
cPtr->entry.clientData = NULL;
cPtr->prevPtr = cPtr->nextPtr = NULL;
return &cPtr->entry;
}
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
static inline void
DeleteChainTable(
Dict *dict)
{
ChainEntry *cPtr;
for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
static inline void
DeleteChainTable(
Dict *dict)
{
ChainEntry *cPtr;
for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
Tcl_DeleteHashTable(&dict->table);
}
static inline Tcl_HashEntry *
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
{
ChainEntry *cPtr = (ChainEntry *)
Tcl_FindHashEntry(&dict->table, keyPtr);
if (cPtr == NULL) {
return 0;
} else {
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
{
ChainEntry *cPtr = (ChainEntry *)
Tcl_FindHashEntry(&dict->table, keyPtr);
if (cPtr == NULL) {
return 0;
} else {
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
/*
* Unstitch from the chain.
*/
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
| | | | | 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 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict));
ChainEntry *cPtr;
DictGetIntRep(srcPtr, oldDict);
/*
* Copy values across from the old hash table.
*/
InitChainTable(newDict);
for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
Tcl_Obj *key = (Tcl_Obj *)Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
int n;
Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
/*
* Fill in the contents.
*/
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
| | | | | | | 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 |
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)ckalloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
/*
* 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);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
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);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - numElems + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
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++ = ' ';
}
(void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
| | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
Dict *dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
|
| ︙ | ︙ | |||
639 640 641 642 643 644 645 |
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
| | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
/*
* Not really a well-formed dictionary as there are duplicate
* keys, so better get the string rep here so that we can
* convert back.
*/
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
(void)Tcl_InitStringRep(valuePtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
| | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
(void)Tcl_InitStringRep(valuePtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(keyPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, valuePtr);
Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
}
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
*/
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
| | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
*/
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
DictGetIntRep(tmpObj, newDict);
if (newDict == NULL) {
if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
return NULL;
}
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeIntRep(dictPtr)
DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
| | | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeIntRep(dictPtr)
DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
dict->epoch++;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
| | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 |
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
dict->refCount++;
if (keyPtrPtr != NULL) {
| | | | 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
dict->refCount++;
if (keyPtrPtr != NULL) {
*keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 |
* removed. This *shouldn't* happen, but...
*/
if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
Tcl_Panic("concurrent dictionary modification and search");
}
| | | | | 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 |
* removed. This *shouldn't* happen, but...
*/
if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
Tcl_Panic("concurrent dictionary modification and search");
}
cPtr = (ChainEntry *)searchPtr->next;
if (cPtr == NULL) {
Tcl_DictObjDone(searchPtr);
*donePtr = 1;
return;
}
searchPtr->next = cPtr->nextPtr;
*donePtr = 0;
if (keyPtrPtr != NULL) {
*keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(
&((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DictObjDone --
|
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 |
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
| | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 |
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
InvalidateDictChain(dictPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
| | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 |
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
| > < | > > > > > > < > | 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 |
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
Tcl_Obj *dictPtr;
Dict *dict;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
}
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDictObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDictObj();
}
#endif
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
/*
*----------------------------------------------------------------------
*
* DictCreateCmd --
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictCreateCmd( | | | 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictCreateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictObj;
int i;
|
| ︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetCmd( | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr = NULL;
int result;
|
| ︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetDefCmd( | | | 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
Tcl_Obj *const *keyPath;
int numKeys;
|
| ︙ | ︙ | |||
1710 1711 1712 1713 1714 1715 1716 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictReplaceCmd( | | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictReplaceCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictRemoveCmd( | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictRemoveCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMergeCmd( | | | 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMergeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
int allocatedDict = 0;
int i, done;
|
| ︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictKeysCmd( | | | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictKeysCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *listPtr;
const char *pattern = NULL;
|
| ︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictValuesCmd( | | | 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictValuesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *valuePtr = NULL, *listPtr;
Tcl_DictSearch search;
int done;
|
| ︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSizeCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result, 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2070 2071 2072 2073 2074 2075 2076 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictExistsCmd( | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
|
| ︙ | ︙ | |||
2112 2113 2114 2115 2116 2117 2118 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictInfoCmd( | | | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictInfoCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Dict *dict;
char *statsStr;
|
| ︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictIncrCmd( | | | 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictIncrCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int code = TCL_OK;
Tcl_Obj *dictPtr, *valuePtr = NULL;
|
| ︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 |
* using it directly. [Bug 2874678]
*/
mp_clear(&increment);
Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
}
} else {
| | | > | 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 |
* using it directly. [Bug 2874678]
*/
mp_clear(&increment);
Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
}
} else {
Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewWideIntObj(1));
}
} else {
/*
* Key in dictionary. Increment its value with minimum dup.
*/
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
if (objc == 4) {
code = TclIncrObj(interp, valuePtr, objv[3]);
} else {
Tcl_Obj *incrPtr;
TclNewIntObj(incrPtr, 1);
Tcl_IncrRefCount(incrPtr);
code = TclIncrObj(interp, valuePtr, incrPtr);
TclDecrRefCount(incrPtr);
}
}
if (code == TCL_OK) {
TclInvalidateStringRep(dictPtr);
|
| ︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictLappendCmd( | | | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictLappendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0, allocatedValue = 0;
|
| ︙ | ︙ | |||
2363 2364 2365 2366 2367 2368 2369 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictAppendCmd( | | | 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictAppendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int allocatedDict = 0;
|
| ︙ | ︙ | |||
2465 2466 2467 2468 2469 2470 2471 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictForNRCmd( | | | 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictForNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
|
| ︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
| | | 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", 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);
|
| ︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 |
static int
DictForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
static int
DictForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_DictSearch *searchPtr = (Tcl_DictSearch *)data[0];
Tcl_Obj *keyVarObj = (Tcl_Obj *)data[1];
Tcl_Obj *valueVarObj = (Tcl_Obj *)data[2];
Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj *keyObj, *valueObj;
int done;
/*
* Process the result from the previous execution of the script body.
*/
|
| ︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMapNRCmd( | | | 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMapNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
|
| ︙ | ︙ | |||
2689 2690 2691 2692 2693 2694 2695 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
| | | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", 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) {
/*
|
| ︙ | ︙ | |||
2769 2770 2771 2772 2773 2774 2775 |
static int
DictMapLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 |
static int
DictMapLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
/*
* Process the result from the previous execution of the script body.
*/
|
| ︙ | ︙ | |||
2872 2873 2874 2875 2876 2877 2878 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSetCmd( | | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
2932 2933 2934 2935 2936 2937 2938 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUnsetCmd( | | | 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUnsetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictFilterCmd( | | | 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictFilterCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
static const char *const filters[] = {
"key", "script", "value", NULL
|
| ︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUpdateCmd( | | | 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUpdateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
int i, dummy;
|
| ︙ | ︙ | |||
3337 3338 3339 3340 3341 3342 3343 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
int i, objc;
| | | | 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
int i, objc;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *argsObj = (Tcl_Obj *)data[1];
/*
* ErrorInfo handling.
*/
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")");
|
| ︙ | ︙ | |||
3434 3435 3436 3437 3438 3439 3440 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictWithCmd( | | | 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictWithCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
|
| ︙ | ︙ | |||
3488 3489 3490 3491 3492 3493 3494 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
| | | | | 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
}
/*
|
| ︙ | ︙ |
Changes to generic/tclDisassemble.c.
1 2 3 4 5 6 | /* * tclDisassemble.c -- * * This file contains procedures that disassemble bytecode into either * human-readable or Tcl-processable forms. * | | | | | < | < | 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 | /* * tclDisassemble.c -- * * This file contains procedures that disassemble bytecode into either * human-readable or Tcl-processable forms. * * Copyright © 1996-1998 Sun Microsystems, Inc. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | * None. * *---------------------------------------------------------------------- */ void TclPrintByteCodeObj( | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* None.
*
*----------------------------------------------------------------------
*/
void
TclPrintByteCodeObj(
TCL_UNUSED(Tcl_Interp *), /* Stuck with this in internal stubs */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | * are made about the details of the contents of the result. * *---------------------------------------------------------------------- */ static Tcl_Obj * DisassembleByteCodeObj( | < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
* are made about the details of the contents of the result.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DisassembleByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
ByteCode *codePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
"ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
| | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
"ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n",
codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
if (line >= 0 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
Tcl_GetString(fileObj), line);
}
Tcl_AppendPrintfToObj(bufferObj,
"\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclNewInstNameObj(
unsigned char inst)
{
| | > | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclNewInstNameObj(
unsigned char inst)
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
InstNameSetIntRep(objPtr, (long) inst);
return objPtr;
}
/*
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
const char *p;
int i = 0, len;
| < > | | | 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 |
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
const char *p;
int i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUCS4(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
i += 2;
continue;
case '\f':
Tcl_AppendToObj(appendObj, "\\f", -1);
i += 2;
|
| ︙ | ︙ | |||
899 900 901 902 903 904 905 | i += 2; continue; case '\v': Tcl_AppendToObj(appendObj, "\\v", -1); i += 2; continue; default: | < < < < < < < < < < | < < | | < < | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 |
i += 2;
continue;
case '\v':
Tcl_AppendToObj(appendObj, "\\v", -1);
i += 2;
continue;
default:
if (ucs4 > 0xFFFF) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
i += 10;
} else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
i += 6;
} else {
Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
i++;
}
continue;
}
}
if (*p != '\0') {
Tcl_AppendToObj(appendObj, "...", -1);
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 | * format. * *---------------------------------------------------------------------- */ static Tcl_Obj * DisassembleByteCodeAsDicts( | < < | | | | 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 |
* format.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DisassembleByteCodeAsDicts(
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
ByteCode *codePtr;
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
int i, val, line;
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
for (i=0 ; i<codePtr->numLitObjects ; i++) {
Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
}
/*
* Get the variables from the bytecode.
*/
TclNewObj(variables);
if (codePtr->procPtr) {
int localCount = codePtr->procPtr->numCompiledLocals;
CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr;
for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
Tcl_Obj *descriptor[2];
TclNewObj(descriptor[0]);
if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) {
Tcl_ListObjAppendElement(NULL, descriptor[0],
Tcl_NewStringObj("scalar", -1));
}
if (localPtr->flags & VAR_ARRAY) {
Tcl_ListObjAppendElement(NULL, descriptor[0],
Tcl_NewStringObj("array", -1));
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
}
}
/*
* Get the instructions from the bytecode.
*/
| | | | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 |
}
}
/*
* Get the instructions from the bytecode.
*/
TclNewObj(instructions);
for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){
const InstructionDesc *instDesc = &tclInstructionTable[*pc];
int address = pc - codePtr->codeStart;
TclNewObj(inst);
Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(
instDesc->name, -1));
opnd = pc + 1;
for (i=0 ; i<instDesc->numOperands ; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
val = TclGetInt1AtPtr(opnd);
|
| ︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 | val = TclGetInt4AtPtr(opnd); opnd += 4; goto formatNumber; case OPERAND_UINT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; formatNumber: | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | val = TclGetInt4AtPtr(opnd); opnd += 4; goto formatNumber; case OPERAND_UINT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; formatNumber: Tcl_ListObjAppendElement(NULL, inst, Tcl_NewWideIntObj(val)); break; case OPERAND_OFFSET1: val = TclGetInt1AtPtr(opnd); opnd += 1; goto formatAddress; case OPERAND_OFFSET4: |
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
"=%s", tclStringClassTable[val].name));
break;
case OPERAND_NONE:
Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
}
}
| | | | > | > | | 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 |
Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
"=%s", tclStringClassTable[val].name));
break;
case OPERAND_NONE:
Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
}
}
Tcl_DictObjPut(NULL, instructions, Tcl_NewWideIntObj(address), inst);
pc += instDesc->numBytes;
}
/*
* Get the auxiliary data from the bytecode.
*/
TclNewObj(aux);
for (i=0 ; i<codePtr->numAuxDataItems ; i++) {
AuxData *auxData = &codePtr->auxDataArrayPtr[i];
Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1);
if (auxData->type->disassembleProc) {
Tcl_Obj *desc;
TclNewObj(desc);
Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc);
auxDesc = desc;
auxData->type->disassembleProc(auxData->clientData, auxDesc,
codePtr, 0);
} else if (auxData->type->printProc) {
Tcl_Obj *desc;
TclNewObj(desc);
auxData->type->printProc(auxData->clientData, desc, codePtr, 0);
Tcl_ListObjAppendElement(NULL, auxDesc, desc);
}
Tcl_ListObjAppendElement(NULL, aux, auxDesc);
}
/*
* Get the exception ranges from the bytecode.
*/
TclNewObj(exn);
for (i=0 ; i<codePtr->numExceptRanges ; i++) {
ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
"type %s level %d from %d to %d break %d continue %d",
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
*/
#define Decode(ptr) \
((TclGetUInt1AtPtr(ptr) == 0xFF) \
? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \
: ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1)))
| | | | | | | | | | | | | 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 |
*/
#define Decode(ptr) \
((TclGetUInt1AtPtr(ptr) == 0xFF) \
? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \
: ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1)))
TclNewObj(commands);
codeOffPtr = codePtr->codeDeltaStart;
codeLenPtr = codePtr->codeLengthStart;
srcOffPtr = codePtr->srcDeltaStart;
srcLenPtr = codePtr->srcLengthStart;
codeOffset = sourceOffset = 0;
for (i=0 ; i<codePtr->numCommands ; i++) {
Tcl_Obj *cmd;
codeOffset += Decode(codeOffPtr);
codeLength = Decode(codeLenPtr);
sourceOffset += Decode(srcOffPtr);
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
Tcl_NewWideIntObj(codeOffset));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
Tcl_NewWideIntObj(codeOffset + codeLength - 1));
/*
* Convert byte offsets to character offsets; important if multibyte
* characters are present in the source!
*/
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source,
sourceOffset + sourceLength - 1)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
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);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1),
literals);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1),
variables);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1),
instructions);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1),
commands);
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1),
Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
Tcl_NewWideIntObj(codePtr->maxStackDepth));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
Tcl_NewWideIntObj(codePtr->maxExceptDepth));
if (line >= 0) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("initiallinenumber", -1),
Tcl_NewWideIntObj(line));
}
if (file) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("sourcefile", -1), file);
}
return description;
}
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } | | | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), 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", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
}
if (clientData) {
Tcl_SetObjResult(interp,
| | | | 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 |
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
}
if (clientData) {
Tcl_SetObjResult(interp,
DisassembleByteCodeAsDicts(codeObjPtr));
} else {
Tcl_SetObjResult(interp,
DisassembleByteCodeObj(codeObjPtr));
}
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclEncoding.c.
1 2 3 4 5 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright © 1996-1998 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" |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
* 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. */
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
* conversion. */
char prefixBytes[256]; /* If a byte in the input stream is the first
* character of one of the escape sequences in
* the following array, the corresponding
* entry in this array is 1, otherwise it is
* 0. */
int numSubTables; /* Length of following array. */
EscapeSubTable subTables[TCLFLEXARRAY];/* Information about each EscapeSubTable used
* by this encoding type. The actual size is
* as large as necessary to hold all
* EscapeSubTables. */
} EscapeEncodingData;
/*
* Constants used when loading an encoding file to identify the type of the
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 | static unsigned short emptyPage[256]; /* * Functions used only in this module. */ | | < < < < | | | < < < < | < < < < | | | | | | > | | | > | | | | > | | < < < | < < | | | | | | < < < < < < < < < < < < < < | | < < < < | < < < < | < < < < | < < < < | 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 |
static unsigned short emptyPage[256];
/*
* Functions used only in this module.
*/
static Tcl_EncodingConvertProc BinaryProc;
static Tcl_DupInternalRepProc DupEncodingIntRep;
static Tcl_EncodingFreeProc EscapeFreeProc;
static Tcl_EncodingConvertProc EscapeFromUtfProc;
static Tcl_EncodingConvertProc EscapeToUtfProc;
static void FillEncodingFileMap(void);
static void FreeEncoding(Tcl_Encoding encoding);
static Tcl_FreeInternalRepProc FreeEncodingIntRep;
static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr,
int state);
static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp,
const char *name);
static Tcl_Encoding LoadTableEncoding(const char *name, int type,
Tcl_Channel chan);
static Tcl_Encoding LoadEscapeEncoding(const char *name,
Tcl_Channel chan);
static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp,
const char *name);
static Tcl_EncodingFreeProc TableFreeProc;
static Tcl_EncodingConvertProc TableFromUtfProc;
static Tcl_EncodingConvertProc TableToUtfProc;
static size_t unilen(const char *src);
static Tcl_EncodingConvertProc Utf16ToUtfProc;
static Tcl_EncodingConvertProc UtfToUtf16Proc;
static Tcl_EncodingConvertProc UtfToUcs2Proc;
static int UtfToUtfProc(ClientData clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr,
int pureNullMode);
static Tcl_EncodingConvertProc UtfIntToUtfExtProc;
static Tcl_EncodingConvertProc UtfExtToUtfIntProc;
static Tcl_EncodingConvertProc Iso88591FromUtfProc;
static Tcl_EncodingConvertProc Iso88591ToUtfProc;
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 |
Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
} while (0)
#define EncodingGetIntRep(objPtr, encoding) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep ((objPtr), &encodingType); \
| | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
} while (0)
#define EncodingGetIntRep(objPtr, encoding) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep ((objPtr), &encodingType); \
(encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_GetEncodingFromObj --
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
for (i = numDirs-1; i >= 0; i--) {
/*
* Iterate backwards through the search path so as we overwrite
* entries found, we favor files earlier on the search path.
*/
int j, numFiles;
| | > | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
for (i = numDirs-1; i >= 0; i--) {
/*
* Iterate backwards through the search path so as we overwrite
* entries found, we favor files earlier on the search path.
*/
int j, numFiles;
Tcl_Obj *directory, *matchFileList;
Tcl_Obj **filev;
Tcl_GlobTypeData readableFiles = {
TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL
};
TclNewObj(matchFileList);
Tcl_ListObjIndex(NULL, searchPath, i, &directory);
Tcl_IncrRefCount(directory);
Tcl_IncrRefCount(matchFileList);
Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
&readableFiles);
Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev);
|
| ︙ | ︙ | |||
639 640 641 642 643 644 645 |
/*
* 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
* code to duplicate the structure of a table encoding here.
*/
| | | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
/*
* 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
* code to duplicate the structure of a table encoding here.
*/
dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = '?';
size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
dataPtr->toUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
dataPtr->fromUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256);
dataPtr->fromUnicode[0] = (unsigned short *) (dataPtr->fromUnicode + 256);
for (i=1 ; i<256 ; i++) {
dataPtr->toUnicode[i] = emptyPage;
dataPtr->fromUnicode[i] = emptyPage;
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 | /* * Call FreeEncoding instead of doing it directly to handle refcounts * like escape encodings use. [Bug 524674] Make sure to call * Tcl_FirstHashEntry repeatedly so that all encodings are eventually * cleaned up. */ | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
* like escape encodings use. [Bug 524674] Make sure to call
* Tcl_FirstHashEntry repeatedly so that all encodings are eventually
* cleaned up.
*/
FreeEncoding((Tcl_Encoding)Tcl_GetHashValue(hPtr));
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
}
Tcl_DeleteHashTable(&encodingTable);
Tcl_MutexUnlock(&encodingMutex);
}
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 |
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return systemEncoding;
}
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
| | | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 |
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return systemEncoding;
}
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return (Tcl_Encoding) encodingPtr;
}
Tcl_MutexUnlock(&encodingMutex);
return LoadEncodingFile(interp, name);
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
void
Tcl_GetEncodingNames(
Tcl_Interp *interp) /* Interp to hold result. */
{
Tcl_HashTable table;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
| | > | | 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 |
void
Tcl_GetEncodingNames(
Tcl_Interp *interp) /* Interp to hold result. */
{
Tcl_HashTable table;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Tcl_Obj *map, *name, *result;
Tcl_DictSearch mapSearch;
int dummy, done = 0;
TclNewObj(result);
Tcl_InitObjHashTable(&table);
/*
* Copy encoding names from loaded encoding table to table.
*/
Tcl_MutexLock(&encodingMutex);
for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
Tcl_CreateHashEntry(&table,
Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
}
Tcl_MutexUnlock(&encodingMutex);
FillEncodingFileMap();
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 |
*/
Tcl_Encoding
Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
| | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
*/
Tcl_Encoding
Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
encodingPtr->name = NULL;
encodingPtr->toUtfProc = typePtr->toUtfProc;
encodingPtr->fromUtfProc = typePtr->fromUtfProc;
encodingPtr->freeProc = typePtr->freeProc;
encodingPtr->nullSize = typePtr->nullSize;
encodingPtr->clientData = typePtr->clientData;
if (typePtr->nullSize == 1) {
|
| ︙ | ︙ | |||
1113 1114 1115 1116 1117 1118 1119 |
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.
*/
| | | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
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 *)ckalloc(strlen(typePtr->encodingName) + 1);
encodingPtr->name = strcpy(name, typePtr->encodingName);
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
}
return (Tcl_Encoding) encodingPtr;
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 | * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtf( | | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
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. */
int srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 | * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternal( | | | 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 |
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
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. */
int srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
|
| ︙ | ︙ | |||
1784 1785 1786 1787 1788 1789 1790 |
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
| | | | | 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 |
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = fallback;
/*
* Read the table that maps characters to Unicode. Performs a single
* malloc to get the memory for the array and all the pages needed by the
* array.
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->toUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
for (i = 0; i < numPages; i++) {
int ch;
const char *p;
int expected = 3 + 16 * (16 * 4 + 1);
if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) {
return NULL;
}
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0F) == 0) {
p++;
}
ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8)
+ (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])];
if (ch != 0) {
used[ch >> 8] = 1;
}
|
| ︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 |
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
| | | | | | 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 |
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->fromUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
for (hi = 0; hi < 256; hi++) {
if (dataPtr->toUnicode[hi] == NULL) {
dataPtr->toUnicode[hi] = emptyPage;
continue;
}
for (lo = 0; lo < 256; lo++) {
int ch = dataPtr->toUnicode[hi][lo];
if (ch != 0) {
page = dataPtr->fromUnicode[ch >> 8];
if (page == NULL) {
page = pageMemPtr;
pageMemPtr += 256;
dataPtr->fromUnicode[ch >> 8] = page;
}
page[ch & 0xFF] = (unsigned short) ((hi << 8) + lo);
}
}
}
if (type == ENCODING_MULTIBYTE) {
/*
* If multibyte encodings don't have a backslash character, define
* one. Otherwise, on Windows, native file names don't work because
* the backslash in the file name maps to the unknown character
* (question mark) when converting from UTF-8 to external encoding.
*/
if (dataPtr->fromUnicode[0] != NULL) {
if (dataPtr->fromUnicode[0][(int)'\\'] == '\0') {
dataPtr->fromUnicode[0][(int)'\\'] = '\\';
}
}
}
if (symbol) {
/*
* Make a special symbol encoding that maps each symbol character from
* its Unicode code point down into page 0, and also ensure that each
|
| ︙ | ︙ | |||
1982 1983 1984 1985 1986 1987 1988 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
| | | 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
dataPtr->fromUnicode[from >> 8][from & 0xFF] = to;
}
}
doneParse:
Tcl_DStringFree(&lineString);
/*
* Package everything into an encoding structure.
|
| ︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 |
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
ckfree(argv);
Tcl_DStringFree(&lineString);
}
| | | | 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 |
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
ckfree(argv);
Tcl_DStringFree(&lineString);
}
size = offsetof(EscapeEncodingData, subTables)
+ Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *)ckalloc(size);
dataPtr->initLen = strlen(init);
memcpy(dataPtr->init, init, dataPtr->initLen + 1);
dataPtr->finalLen = strlen(final);
memcpy(dataPtr->final, final, dataPtr->finalLen + 1);
dataPtr->numSubTables =
Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData),
|
| ︙ | ︙ | |||
2151 2152 2153 2154 2155 2156 2157 | * None. * *------------------------------------------------------------------------- */ static int BinaryProc( | | | < < < < | 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
BinaryProc(
TCL_UNUSED(ClientData),
const char *src, /* Source string (unknown 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. */
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. */
int *dstWrotePtr, /* Filled with the number of bytes that were
|
| ︙ | ︙ | |||
2201 2202 2203 2204 2205 2206 2207 | /* *------------------------------------------------------------------------- * * UtfIntToUtfExtProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the | | | | 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 |
/*
*-------------------------------------------------------------------------
*
* UtfIntToUtfExtProc --
*
* Convert from UTF-8 to UTF-8. While converting null-bytes from the
* Tcl's internal representation (0xC0, 0x80) to the official
* representation (0x00). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfIntToUtfExtProc(
ClientData clientData,
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
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 | /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the | | | | 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 |
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8 while converting null-bytes from the
* official representation (0x00) to Tcl's internal representation (0xC0,
* 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfExtToUtfIntProc(
ClientData clientData,
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
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2313 2314 2315 2316 2317 2318 2319 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtfProc( | | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtfProc(
TCL_UNUSED(ClientData),
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
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 |
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
* versa. Also combine or separate surrogate pairs */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
| | | | > | | > | | | | | | | | 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 |
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
* versa. Also combine or separate surrogate pairs */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
int *chPtr = (int *) statePtr;
if (flags & TCL_ENCODING_START) {
*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;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!TclUCS4Complete(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 && pureNullMode == 0)) {
/*
* Copy 7bit characters, but skip null-bytes when we are in input
* mode, so that they get converted to 0xC080.
*/
*dst++ = *src++;
*chPtr = 0; /* reset surrogate handling */
} else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 &&
(src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) {
/*
* Convert 0xC080 to real nulls when we are in output mode.
*/
*dst++ = 0;
*chPtr = 0; /* reset surrogate handling */
src += 2;
} else if (!TclUCS4Complete(src, srcEnd - src)) {
/*
* Always check before using TclUtfToUCS4. Not doing can so
* cause it run beyond the end of the buffer! If we happen such an
* incomplete char its bytes are made to represent themselves.
*/
*chPtr = UCHAR(*src);
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
src += TclUtfToUCS4(src, chPtr);
if ((*chPtr | 0x7FF) == 0xDFFF) {
/* A surrogate character is detected, handle especially */
int low = *chPtr;
size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) {
*dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((*chPtr | 0x80) & 0xBF);
continue;
}
src += len;
dst += Tcl_UniCharToUtf(*chPtr, dst);
|
| ︙ | ︙ | |||
2451 2452 2453 2454 2455 2456 2457 |
static int
Utf16ToUtfProc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
| | < < < < | 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 |
static int
Utf16ToUtfProc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
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
* 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
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
| < < < < < | < < > > | 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 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
if (clientData) {
#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
} else {
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
*dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (*chPtr & 0xFF);
*dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
}
#else
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
#endif
} else {
#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr >> 8);
*dst++ = (*chPtr & 0xFF);
} else {
*dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
*dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
*dst++ = (*chPtr & 0xFF);
}
#else
*dst++ = (*chPtr >> 8);
*dst++ = (*chPtr & 0xFF);
#endif
}
}
|
| ︙ | ︙ | |||
2670 2671 2672 2673 2674 2675 2676 |
static int
UtfToUcs2Proc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
| | < < < < | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 |
static int
UtfToUcs2Proc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
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
* 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
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 |
static int
TableToUtfProc(
ClientData 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. */
| | < < < < | 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 |
static int
TableToUtfProc(
ClientData 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. */
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
|
| ︙ | ︙ | |||
2806 2807 2808 2809 2810 2811 2812 |
{
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars, charLimit = INT_MAX;
Tcl_UniChar ch = 0;
const unsigned short *const *toUnicode;
const unsigned short *pageZero;
| | | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 |
{
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars, charLimit = INT_MAX;
Tcl_UniChar ch = 0;
const unsigned short *const *toUnicode;
const unsigned short *pageZero;
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
srcStart = src;
srcEnd = src + srcLen;
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
static int
TableFromUtfProc(
ClientData 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. */
| | < < < < | | 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 |
static int
TableFromUtfProc(
ClientData 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. */
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
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd, *prefixBytes;
Tcl_UniChar ch = 0;
int result, len, word, numChars;
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
const unsigned short *const *fromUnicode;
result = TCL_OK;
prefixBytes = dataPtr->prefixBytes;
fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode;
|
| ︙ | ︙ | |||
2953 2954 2955 2956 2957 2958 2959 | #if TCL_UTF_MAX > 3 /* * This prevents a crash condition. More evaluation is required for * full support of int Tcl_UniChar. [Bug 1004065] */ | | | | 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 |
#if TCL_UTF_MAX > 3
/*
* This prevents a crash condition. More evaluation is required for
* full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xFFFF0000) {
word = 0;
} else
#else
if (!len) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
word = dataPtr->fallback;
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 | * None. * *------------------------------------------------------------------------- */ static int Iso88591ToUtfProc( | | | < < < < | 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Iso88591ToUtfProc(
TCL_UNUSED(ClientData),
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. */
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
|
| ︙ | ︙ | |||
3097 3098 3099 3100 3101 3102 3103 | * None. * *------------------------------------------------------------------------- */ static int Iso88591FromUtfProc( | | | < < < < | < < | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Iso88591FromUtfProc(
TCL_UNUSED(ClientData),
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
* 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
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result = TCL_OK, numChars;
Tcl_UniChar ch = 0;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 | } len = TclUtfToUniChar(src, &ch); /* * Check for illegal characters. */ | | | 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 |
}
len = TclUtfToUniChar(src, &ch);
/*
* Check for illegal characters.
*/
if (ch > 0xFF
#if TCL_UTF_MAX <= 3
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
|
| ︙ | ︙ | |||
3212 3213 3214 3215 3216 3217 3218 |
*/
static void
TableFreeProc(
ClientData clientData) /* TableEncodingData that specifies
* encoding. */
{
| | | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 |
*/
static void
TableFreeProc(
ClientData clientData) /* TableEncodingData that specifies
* encoding. */
{
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
*/
ckfree(dataPtr->toUnicode);
dataPtr->toUnicode = NULL;
|
| ︙ | ︙ | |||
3270 3271 3272 3273 3274 3275 3276 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | | | | 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 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd;
const unsigned short *const *tableToUnicode;
const Encoding *encodingPtr;
int state, result, numChars, charLimit = INT_MAX;
const char *dstStart, *dstEnd;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
tablePrefixBytes = NULL;
tableToUnicode = NULL;
prefixBytes = dataPtr->prefixBytes;
encodingPtr = NULL;
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
|
| ︙ | ︙ | |||
3406 3407 3408 3409 3410 3411 3412 |
break;
}
if (encodingPtr == NULL) {
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
| | | 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 |
break;
}
if (encodingPtr == NULL) {
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *)encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableToUnicode = (const unsigned short *const*)
tableDataPtr->toUnicode;
}
if (tablePrefixBytes[byte]) {
src++;
|
| ︙ | ︙ | |||
3484 3485 3486 3487 3488 3489 3490 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | | 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const Encoding *encodingPtr;
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int state, result, numChars;
const TableEncodingData *tableDataPtr;
const char *tablePrefixBytes;
const unsigned short *const *tableFromUnicode;
|
| ︙ | ︙ | |||
3525 3526 3527 3528 3529 3530 3531 |
memcpy(dst, dataPtr->init, dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = PTR2INT(*statePtr);
}
encodingPtr = GetTableEncoding(dataPtr, state);
| | | | | | | 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 |
memcpy(dst, dataPtr->init, dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = PTR2INT(*statePtr);
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
unsigned len;
int word;
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;
}
len = TclUtfToUniChar(src, &ch);
word = tableFromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
int oldState;
const EscapeSubTable *subTablePtr;
oldState = state;
for (state = 0; state < dataPtr->numSubTables; state++) {
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF];
if (word != 0) {
break;
}
}
if (word == 0) {
state = oldState;
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
word = tableDataPtr->fallback;
}
tablePrefixBytes = (const char *) tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
|
| ︙ | ︙ | |||
3673 3674 3675 3676 3677 3678 3679 |
*/
static void
EscapeFreeProc(
ClientData clientData) /* EscapeEncodingData that specifies
* encoding. */
{
| | | 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 |
*/
static void
EscapeFreeProc(
ClientData clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
EscapeSubTable *subTablePtr;
int i;
if (dataPtr == NULL) {
return;
}
|
| ︙ | ︙ | |||
3838 3839 3840 3841 3842 3843 3844 |
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = TclGetString(searchPathObj);
*lengthPtr = searchPathObj->length;
| | | 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 |
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = TclGetString(searchPathObj);
*lengthPtr = searchPathObj->length;
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnsemble.c.
1 2 3 4 5 6 | /* * tclEnsemble.c -- * * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclEnsemble.c -- * * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * * Copyright © 2005-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" |
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
} while (0)
#define ECRGetIntRep(objPtr, ecRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
| | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
} while (0)
#define ECRGetIntRep(objPtr, ecRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
(ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The internal rep for caching ensemble subcommand lookups and spelling
* corrections.
*/
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 | * implementation prefix is configured. * *---------------------------------------------------------------------- */ int TclNamespaceEnsembleCmd( | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
* implementation prefix is configured.
*
*----------------------------------------------------------------------
*/
int
TclNamespaceEnsembleCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
*foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
/* Name of the namespace for the ensemble. */
int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
| | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 |
/* Name of the namespace for the ensemble. */
int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
(Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
ckfree(ensemblePtr);
return NULL;
}
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
| | | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 |
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
Tcl_IncrRefCount(subcmdList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
| | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
Tcl_IncrRefCount(paramList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
}
if (size < 1) {
mapDict = NULL;
}
}
| | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
}
if (size < 1) {
mapDict = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
Tcl_IncrRefCount(mapDict);
}
if (oldDict != NULL) {
TclDecrRefCount(oldDict);
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 |
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
Tcl_IncrRefCount(unknownList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
/*
* This API refuses to set the ENSEMBLE_DEAD flag...
*/
ensemblePtr->flags &= ENSEMBLE_DEAD;
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 |
static int
NsEnsembleImplementationCmdNR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 |
static int
NsEnsembleImplementationCmdNR(
ClientData clientData,
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. */
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 |
*/
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(subObj, ensembleCmd);
if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
| | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
*/
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(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;
}
}
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
| | | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
* 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:
/*
* Do the real work of execution of the subcommand by building an array of
* objects (note that this is potentially not the same length as the
* number of arguments to this ensemble command), populating it and then
|
| ︙ | ︙ | |||
1983 1984 1985 1986 1987 1988 1989 |
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
| | | 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 |
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
TclResetRewriteEnsemble(interp, 1);
return result;
}
|
| ︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 |
*
*----------------------------------------------------------------------
*/
static int
FreeER(
ClientData data[],
| | | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 |
*
*----------------------------------------------------------------------
*/
static int
FreeER(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
Tcl_Obj **store = (Tcl_Obj **) data[1];
ckfree(store);
ckfree(tmp);
|
| ︙ | ︙ | |||
2172 2173 2174 2175 2176 2177 2178 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
| | | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
store = (Tcl_Obj **)ckalloc(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.
|
| ︙ | ︙ | |||
2414 2415 2416 2417 2418 2419 2420 |
}
} else {
/*
* Kill the old internal rep, and replace it with a brand new one of
* our own.
*/
| | | 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 |
}
} else {
/*
* Kill the old internal rep, and replace it with a brand new one of
* our own.
*/
ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
ECRSetIntRep(objPtr, ensembleCmd);
}
/*
* Populate the internal rep.
*/
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 |
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
if (hash->numEntries != 0) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
| | | | 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 |
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);
}
ckfree((char *) ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
ClientData clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
/*
* Unlink from the ensemble chain if it has not been marked as having been
* done already.
*/
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
* place them in the hash too, which should make for even faster
* matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = /* Name of command in namespace. */
| | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 |
* place them in the hash too, which should make for even faster
* matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = /* Name of command in namespace. */
(char *)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);
/*
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
*
* We do this by filling an array with the names (we 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 running quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
| | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
*
* We do this by filling an array with the names (we 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 running quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
(char **)ckalloc(sizeof(char *) * hash->numEntries);
/*
* Fill array from both ends as this makes us less likely to end up with
* performance problems in qsort(), which is good. Note that doing this
* makes this code much more opaque, but the naive alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
* awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
| | | | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 |
* 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);
}
}
|
| ︙ | ︙ | |||
2857 2858 2859 2860 2861 2862 2863 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
| | | 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
ECRGetIntRep(objPtr, ensembleCmd);
ECRSetIntRep(copyPtr, ensembleCopy);
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
|
| ︙ | ︙ | |||
2902 2903 2904 2905 2906 2907 2908 2909 2910 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
| > | < > | 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 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
unsigned numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords < depth + 1) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard.
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 |
goto cleanup;
}
ensemble = (Tcl_Command) cmdPtr;
goto checkNextWord;
}
/*
| | | 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 |
goto cleanup;
}
ensemble = (Tcl_Command) cmdPtr;
goto checkNextWord;
}
/*
* Now that the mapping process is done we actually try to compile.
* If there is a subcommand compiler and that successfully produces code,
* we'll use that. Otherwise, we fall back to generating opcodes to do the
* invoke at runtime.
*/
invokeAnyway = 1;
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
|
| ︙ | ︙ | |||
3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
| > < | | | | 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 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
* This will be wrong but it will not matter, and it will put the
* tokens for the arguments in the right place without the need to
* allocate a synthetic Tcl_Parse struct or copy tokens around.
*/
for (i = 0; i < depth - 1; i++) {
parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
}
parsePtr->numWords -= (depth - 1);
|
| ︙ | ︙ | |||
3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
| > < | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
/*
* 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...
*/
|
| ︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 |
}
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
| | | 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 |
}
/*
* 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 = TclGetString(objPtr);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
|
| ︙ | ︙ | |||
3455 3456 3457 3458 3459 3460 3461 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| | > | 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
parsePtr->numWords, envPtr);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
1 2 3 4 5 6 7 8 | /* * tclEnv.c -- * * Tcl support for environment variables, including a setenv function. * This file contains the generic portion of the environment module. It * is primarily responsible for keeping the "env" arrays in sync with the * system environment variables. * | | | > > > > > > > > > > > > > > > > > > > | > > | 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 |
/*
* tclEnv.c --
*
* Tcl support for environment variables, including a setenv function.
* This file contains the generic portion of the environment module. It
* is primarily responsible for keeping the "env" arrays in sync with the
* system environment variables.
*
* Copyright © 1991-1994 The Regents of the University of California.
* Copyright © 1994-1998 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"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
# define tenviron2utfdstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
# define utf2tenvirondstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(const WCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
# endif
#else
# define tenviron environ
# define tenviron2utfdstr(tenvstr, len, dstr) \
Tcl_ExternalToUtfDString(NULL, tenvstr, len, dstr)
# define utf2tenvirondstr(str, len, dstr) \
Tcl_UtfToExternalDString(NULL, str, len, dstr)
# define techar char
#endif
static struct {
int cacheSize; /* Number of env strings in cache. */
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
techar **ourEnviron; /* Cache of the array that we allocate. We
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
int ourEnvironSize; /* Non-zero means that the environ array was
* malloced and has this many total entries
* allocated to it (not all may be in use at
* once). Zero means that the environment
* array is in its original static state. */
#endif
} env;
#define tNTL sizeof(techar)
/*
* Declarations for local functions defined in this file:
*/
static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
| > > > > > > > > > > > | | | | | 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 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
#if defined(_WIN32)
if (tenviron == NULL) {
/*
* When we are started from main(), the _wenviron array could
* be NULL and will be initialized by the first _wgetenv() call.
*/
(void) _wgetenv(L"WINDIR");
}
#endif
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
if (tenviron[0] != NULL) {
int i;
Tcl_MutexLock(&envMutex);
for (i = 0; tenviron[i] != NULL; i++) {
Tcl_Obj *obj1, *obj2;
const char *p1;
char *p2;
p1 = tenviron2utfdstr(tenviron[i], -1, &envString);
p2 = (char *)strchr(p1, '=');
if (p2 == NULL) {
/*
* This condition seem to happen occasionally under some
* versions of Solaris, or when encoding accidents swallow the
* '='; ignore the entry.
*/
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
/*
* Delete those elements that existed in the array but which had no
* counterparts in the environment array.
*/
for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
| | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
/*
* Delete those elements that existed in the array but which had no
* counterparts in the environment array.
*/
for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
Tcl_Obj *elemName = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
}
Tcl_DeleteHashTable(&namesHash);
Tcl_DecrRefCount(varNamePtr);
/*
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
unsigned nameLength, valueLength;
int index, length;
char *p, *oldValue;
| | | | | | | | | | | | | | | | | | 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 |
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
unsigned nameLength, valueLength;
int index, length;
char *p, *oldValue;
const techar *p2;
/*
* Figure out where the entry is going to go. If the name doesn't already
* exist, enlarge the array if necessary to make room. If the name exists,
* free its old entry.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. ourEnvironSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) {
techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *));
memcpy(newEnviron, tenviron, length * sizeof(techar *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
ckfree(env.ourEnviron);
}
tenviron = (env.ourEnviron = newEnviron);
env.ourEnvironSize = length + 5;
}
index = length;
tenviron[index + 1] = NULL;
#endif /* USE_PUTENV */
oldValue = NULL;
nameLength = strlen(name);
} else {
const char *oldEnv;
/*
* Compare the new value to the existing value. If they're the same
* then quit immediately (e.g. don't rewrite the value or propagate it
* to other interpreters). Otherwise, when there are N interpreters
* there will be N! propagations of the same value among the
* interpreters.
*/
oldEnv = tenviron2utfdstr(tenviron[index], -1, &envString);
if (strcmp(value, oldEnv + (length + 1)) == 0) {
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
oldValue = (char *)tenviron[index];
nameLength = length;
}
/*
* Create a new entry. Build a complete UTF string that contains a
* "name=value" pattern. Then convert the string to the native encoding,
* and set the environ array value.
*/
valueLength = strlen(value);
p = (char *)ckalloc(nameLength + valueLength + 2);
memcpy(p, name, nameLength);
p[nameLength] = '=';
memcpy(p+nameLength+1, value, valueLength+1);
p2 = utf2tenvirondstr(p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL);
memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
tenviron[index] = (techar *)p;
#endif /* USE_PUTENV */
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if ((index != -1) && (tenviron[index] == (techar *)p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
/*
* First convert the native string to UTF. Then separate the string into
* name and value parts, and call TclSetEnv to do all of the real work.
*/
name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
| | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
/*
* First convert the native string to UTF. Then separate the string into
* name and value parts, and call TclSetEnv to do all of the real work.
*/
name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
value = (char *)strchr(name, '=');
if ((value != NULL) && (value != name)) {
value[0] = '\0';
TclSetEnv(name, value+1);
}
Tcl_DStringFree(&nameString);
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
| | | | | | | | | | 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 |
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = (char *)tenviron[index];
/*
* Update the system environment. This must be done before we update the
* interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(_WIN32)
string = (char *)ckalloc(length + 2);
memcpy(string, name, length);
string[length] = '=';
string[length+1] = '\0';
#else
string = (char *)ckalloc(length + 1);
memcpy(string, name, length);
string[length] = '\0';
#endif /* _WIN32 */
utf2tenvirondstr(string, -1, &envString);
string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL);
memcpy(string, Tcl_DStringValue(&envString),
Tcl_DStringLength(&envString) + tNTL);
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if (tenviron[index] == (techar *)string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(string);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
#else /* !USE_PUTENV_FOR_UNSET */
for (envPtr = (char **)(tenviron+index+1); ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
}
ReplaceString(oldValue, NULL);
#endif /* USE_PUTENV_FOR_UNSET */
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
result = NULL;
if (index != -1) {
Tcl_DString envStr;
| | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
result = NULL;
if (index != -1) {
Tcl_DString envStr;
result = tenviron2utfdstr(tenviron[index], -1, &envStr);
result += length;
if (*result == '=') {
result++;
Tcl_DStringInit(valuePtr);
Tcl_DStringAppend(valuePtr, result, -1);
result = Tcl_DStringValue(valuePtr);
} else {
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 | * Environment variable changes get propagated. If the whole "env" array * is deleted, then we stop managing things for this interpreter (usually * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ | < | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
* Environment variable changes get propagated. If the whole "env" array
* is deleted, then we stop managing things for this interpreter (usually
* this happens because the whole interpreter is being deleted).
*
*----------------------------------------------------------------------
*/
static char *
EnvTraceProc(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
const char *name2, /* Name of variable being modified, or NULL if
* whole array is being deleted (UTF-8). */
int flags) /* Indicates what's happening. */
{
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
} else {
/*
* We need to grow the cache in order to hold the new string.
*/
const int growth = 5;
| | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
} else {
/*
* We need to grow the cache in order to hold the new string.
*/
const int growth = 5;
env.cache = (char **)ckrealloc(env.cache,
(env.cacheSize + growth) * sizeof(char *));
env.cache[env.cacheSize] = newStr;
(void) memset(env.cache+env.cacheSize+1, 0,
(size_t) (growth-1) * sizeof(char *));
env.cacheSize += growth;
}
}
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
1 2 3 4 5 6 7 | /* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" command * functions. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" command * functions. * * Copyright © 1990-1994 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2004 Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
| | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
void *clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers. The first list is
* controlled by a mutex. The other is in thread local storage.
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
| | | | | | | 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 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
void *clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(void *clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
static void BgErrorDeleteProc(void *clientData,
Tcl_Interp *interp);
static void HandleBgErrors(void *clientData);
static char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
static void FinalizeThread(int quick);
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
| | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
errPtr = (BgError*)ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
assocPtr->lastBgPtr = errPtr;
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors( | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
* Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(
void *clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
/*
* Not bothering to save/restore the interp state. Assume that any code
* that has interp state it needs to keep will make its own
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 | */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); tempObjv = (Tcl_Obj**)ckalloc((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); /* |
| ︙ | ︙ | |||
307 308 309 310 311 312 313 | * Depends on what actions the "bgerror" command takes for the errors. * *---------------------------------------------------------------------- */ int TclDefaultBgErrorHandlerObjCmd( | | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
* Depends on what actions the "bgerror" command takes for the errors.
*
*----------------------------------------------------------------------
*/
int
TclDefaultBgErrorHandlerObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
int result, code, level;
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
| | | | 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 |
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
| | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 | * reports, they are canceled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( | | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
* reports, they are canceled.
*
*----------------------------------------------------------------------
*/
static void
BgErrorDeleteProc(
void *clientData, /* Pointer to ErrAssocData structure. */
TCL_UNUSED(Tcl_Interp *))
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
|
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ | | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 | /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ TclInitThreadStorage(); /* Creates hash table for * thread local storage */ #if defined(USE_TCLALLOC) && USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif #if TCL_THREADS && defined(USE_THREAD_ALLOC) TclInitThreadAlloc(); /* Setup thread allocator caches */ #endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ |
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
| | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* Undo all Tcl_ObjType registrations, and reset the global list of free
* Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or
* freed.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's the
* Tcl_Obj that holds the path of the current working directory.
*/
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
| | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
tsdPtr = (ThreadSpecificData*)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
* Be careful to remove the handler from the list before invoking
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
| | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
}
return tsdPtr->inExit;
}
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < > | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_VwaitObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
const char *nameString;
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 |
* handlers.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
| < | | | | | 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 |
* handlers.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
static char *
VwaitVarProc(
void *clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
TCL_UNUSED(int) /*flags*/) /* Information about what happened. */
{
int *donePtr = (int *)clientData;
*donePtr = 1;
Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < > | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpdateObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static const char *const updateOptions[] = {"idletasks", NULL};
enum updateOptionsEnum {OPT_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
} else if (objc == 2) {
if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptionsEnum) optionIndex) {
case OPT_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
}
} else {
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 | * Initializes Tcl notifier for the current thread. * *---------------------------------------------------------------------- */ static Tcl_ThreadCreateType NewThreadProc( | | | | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 |
* Initializes Tcl notifier for the current thread.
*
*----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
void *clientData)
{
ThreadClientData *cdPtr = (ThreadClientData *)clientData;
void *threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree(clientData); /* Allocated in Tcl_CreateThread() */
threadProc(threadClientData);
|
| ︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 |
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
| | | | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData));
int result;
cdPtr->proc = proc;
cdPtr->clientData = clientData;
result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
if (result != TCL_OK) {
ckfree(cdPtr);
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
1 2 3 4 5 | /* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl commands. * | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl commands. * * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2002-2010 Miguel Sofer. * Copyright © 2005-2007 Donal K. Fellows. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright © 2006-2008 Joe Mistachkin. 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 "tclCompile.h" |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \
auxObjList = objPtr; \
} while (0)
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
| | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \
auxObjList = objPtr; \
} while (0)
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \
Tcl_DecrRefCount(tmpPtr); \
} while (0)
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
| | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
}
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 |
* that counts the executions of each instruction and it creates the
* "evalstats" command. It also establishes the link between the Tcl
* "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#endif
| > | < < > > > > > > > > > | 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 |
* that counts the executions of each instruction and it creates the
* "evalstats" command. It also establishes the link between the Tcl
* "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
#if defined(TCL_COMPILE_STATS) || defined(TCL_COMPILE_DEBUG)
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#endif
#ifdef TCL_COMPILE_STATS
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
#else
static void
InitByteCodeExecution(
TCL_UNUSED(Tcl_Interp *))
{
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCreateExecEnv --
*
* This procedure creates a new execution environment for Tcl bytecode
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
| | | | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords)
+ size * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 |
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
| | | | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
esPtr->nextPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[newElems-1];
newStackReady:
|
| ︙ | ︙ | |||
1354 1355 1356 1357 1358 1359 1360 |
Tcl_NRExprObj(interp, objPtr, resultPtr);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
static int
CopyCallback(
ClientData data[],
| | | | < | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
Tcl_NRExprObj(interp, objPtr, resultPtr);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
static int
CopyCallback(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0];
Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
*resultPtrPtr = resultPtr;
Tcl_IncrRefCount(resultPtr);
} else {
Tcl_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 |
static int
ExprObjCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
static int
ExprObjCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_InterpState state = (Tcl_InterpState)data[0];
Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
(void) Tcl_RestoreInterpState(interp, state);
} else {
Tcl_DiscardInterpState(state);
}
|
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | * None. * *---------------------------------------------------------------------- */ static void DupExprCodeInternalRep( | | | < < | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
* None.
*
*----------------------------------------------------------------------
*/
static void
DupExprCodeInternalRep(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj *))
{
return;
}
/*
*----------------------------------------------------------------------
*
* FreeExprCodeInternalRep --
|
| ︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 |
CmdFrame *ctxCopyPtr;
int redo;
if (!hePtr) {
return codePtr;
}
| | | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
CmdFrame *ctxCopyPtr;
int redo;
if (!hePtr) {
return codePtr;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
redo = 0;
ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxCopyPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr used instead
*/
|
| ︙ | ︙ | |||
2062 2063 2064 2065 2066 2067 2068 |
#define TCONST(i) (constants[(i)])
/*
* These macros are just meant to save some global variables that are not
* used too frequently
*/
| | | | 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 |
#define TCONST(i) (constants[(i)])
/*
* These macros are just meant to save some global variables that are not
* used too frequently
*/
TEBCdata *TD = (TEBCdata *)data[0];
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
#define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */
/*
* 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.
*/
|
| ︙ | ︙ | |||
2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
if (bcFramePtr->cmdObj) {
| > > > > > > > > > > > > > > > > | 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 |
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
/*
* Reset the interp's result to avoid possible duplications of large
* objects [3c6e47363e], [781585], [804681], This can happen by start
* also in nested compiled blocks (enclosed in parent cycle).
* See else branch below for opposite handling by continuation/resume.
*/
objPtr = iPtr->objResultPtr;
if (objPtr->refCount > 1) {
TclDecrRefCount(objPtr);
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) {
|
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 |
* instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
| | | 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 |
* instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
* Obtain and reset interp's result to avoid possible duplications of
* objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any
* side effects caused by the resetting of errorInfo and errorCode
* [Bug 804681], which are not needed here. We chose instead to
* manipulate the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it keeps the
* refCount it had in its role of iPtr->objResultPtr.
|
| ︙ | ︙ | |||
3610 3611 3612 3613 3614 3615 3616 |
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
increment = TclGetInt1AtPtr(pc+1);
| | | 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 |
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
increment = TclGetInt1AtPtr(pc+1);
TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 2;
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
part2Ptr = OBJ_AT_TOS;
|
| ︙ | ︙ | |||
3645 3646 3647 3648 3649 3650 3651 |
}
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
increment = TclGetInt1AtPtr(pc+2);
| | | 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 |
}
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
increment = TclGetInt1AtPtr(pc+2);
TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 3;
doIncrArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
|
| ︙ | ︙ | |||
3711 3712 3713 3714 3715 3716 3717 |
goto doneIncr;
}
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
| | | 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 |
goto doneIncr;
}
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
TclNewIntObj(objResultPtr, w + increment);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
/*
* We know the sum value is outside the long range;
|
| ︙ | ︙ | |||
4439 4440 4441 4442 4443 4444 4445 |
NEXT_INST_F(1, 0, 1);
}
break;
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
| | | 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 |
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,
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
|
| ︙ | ︙ | |||
4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 |
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_ORIGIN_COMMAND:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
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), NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
| > > > > > > > > > > > > < < < < < < | 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 |
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
case INST_ORIGIN_COMMAND:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
goto instOriginError;
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(objResultPtr);
Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
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), 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);
}
/*
* -----------------------------------------------------------------
* Start of TclOO support instructions.
|
| ︙ | ︙ | |||
4542 4543 4544 4545 4546 4547 4548 | "self may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 |
"self may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
*/
objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
TRACE_WITH_OBJ(("=> "), objResultPtr);
|
| ︙ | ︙ | |||
4570 4571 4572 4573 4574 4575 4576 | "nextto may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 |
"nextto may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
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;
|
| ︙ | ︙ | |||
4669 4670 4671 4672 4673 4674 4675 | "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 |
"next may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless
* the interpreter is being torn down, in which case we might be
* getting here because of methods/destructors doing a [next] (or
|
| ︙ | ︙ | |||
4832 4833 4834 4835 4836 4837 4838 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
| | > > > | > | | | | | > > | 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 |
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
*/
if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
&& !TclHasIntRep(value2Ptr, &tclListType)) {
int code;
DECACHE_STACK_INFO();
code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index);
CACHE_STACK_INFO();
if (code == TCL_OK) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
}
Tcl_ResetResult(interp);
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
}
|
| ︙ | ︙ | |||
5039 5040 5041 5042 5043 5044 5045 |
goto emptyList;
}
/* Decode index value operands. */
if (toIdx == TCL_INDEX_NONE) {
emptyList:
| | | 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 |
goto emptyList;
}
/* Decode index value operands. */
if (toIdx == TCL_INDEX_NONE) {
emptyList:
TclNewObj(objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
}
toIdx = TclIndexDecode(toIdx, objc - 1);
if (toIdx < 0) {
goto emptyList;
} else if (toIdx >= objc) {
|
| ︙ | ︙ | |||
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 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if ((index < 0) || (index >= length)) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
char buf[4] = "";
int ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be faster in
* practical use.
*/
if (ch == -1) {
| > > > | > > | > > > > | > > | 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 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if ((index < 0) || (index >= length)) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
char buf[4] = "";
int ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be faster in
* practical use.
*/
if (ch == -1) {
TclNewObj(objResultPtr);
} else {
length = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (length < 3)) {
length += Tcl_UniCharToUtf(-1, buf + length);
}
objResultPtr = Tcl_NewStringObj(buf, length);
}
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= length) {
toIdx = length;
}
|
| ︙ | ︙ | |||
5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
endIdx = Tcl_GetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
&toIdx) != TCL_OK) {
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
if ((toIdx < 0) ||
(fromIdx > endIdx) ||
| > > > | 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 |
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
endIdx = 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, endIdx,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
&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 > endIdx) ||
|
| ︙ | ︙ | |||
5513 5514 5515 5516 5517 5518 5519 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
| | | | < | | | < > | > | | 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %s\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
TRACE(("%.20s %.20s => %s\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
opnd = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS;
TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
O2S(valuePtr)));
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
match = 1;
if (length > 0) {
int ch;
end = ustring1 + length;
for (p=ustring1 ; p<end ; ) {
p += TclUniCharToUCS4(p, &ch);
if (!tclStringClassTable[opnd].comparator(ch)) {
match = 0;
break;
}
}
}
TRACE_APPEND(("%d\n", match));
JUMP_PEEPHOLE_F(match, 2, 1);
|
| ︙ | ︙ | |||
6105 6106 6107 6108 6109 6110 6111 |
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
| | | 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 |
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, wResult);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
TclSetIntObj(valuePtr, wResult);
TRACE(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
break;
|
| ︙ | ︙ | |||
6376 6377 6378 6379 6380 6381 6382 |
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
| | | | 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 |
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(res);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_BREAK:
/*
|
| ︙ | ︙ | |||
6422 6423 6424 6425 6426 6427 6428 |
case INST_FOREACH_START4: /* DEPRECATED */
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
opnd = TclGetUInt4AtPtr(pc+1);
| | | 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 |
case INST_FOREACH_START4: /* DEPRECATED */
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
TclNewIntObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
|
| ︙ | ︙ | |||
6456 6457 6458 6459 6460 6461 6462 |
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
| | | 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 |
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
|
| ︙ | ︙ | |||
6571 6572 6573 6574 6575 6576 6577 |
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
{
ForeachInfo *infoPtr;
| | | | 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 |
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
{
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
int numLists, listLen, numVars;
int listTmpDepth;
size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
case INST_FOREACH_START:
/*
* Initialize the data for the looping construct, pushing the
* corresponding Tcl_Objs to the stack.
*/
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
/*
* Compute the number of iterations that will be run: iterMax
*/
|
| ︙ | ︙ | |||
6654 6655 6656 6657 6658 6659 6660 |
case INST_FOREACH_STEP:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
tmpPtr = OBJ_AT_TOS;
| | | 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 |
case INST_FOREACH_STEP:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
tmpPtr = OBJ_AT_TOS;
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> "));
tmpPtr = OBJ_AT_DEPTH(1);
iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1;
iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2;
|
| ︙ | ︙ | |||
6738 6739 6740 6741 6742 6743 6744 |
*/
pc++;
#endif
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
| | | | 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 |
*/
pc++;
#endif
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> loop terminated\n"));
NEXT_INST_V(1, numLists+2, 0);
case INST_LMAP_COLLECT:
/*
* This instruction is only issued by lmap. The stack is:
* - result
* - infoPtr
* - loop counters
* - valLists
* - collecting obj (unshared)
* The instruction lappends the result to the collecting obj.
*/
tmpPtr = OBJ_AT_DEPTH(1);
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
objPtr = OBJ_AT_DEPTH(3 + numLists);
Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
NEXT_INST_F(1, 1, 0);
}
|
| ︙ | ︙ | |||
6995 6996 6997 6998 6999 7000 7001 |
cleanup = 1;
opnd = TclGetInt4AtPtr(pc+1);
result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
if (valuePtr == NULL) {
| | | | 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 |
cleanup = 1;
opnd = TclGetInt4AtPtr(pc+1);
result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
if (valuePtr == NULL) {
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd));
} else {
TclNewIntObj(value2Ptr, opnd);
Tcl_IncrRefCount(value2Ptr);
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr);
}
result = TclIncrObj(interp, valuePtr, value2Ptr);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
7202 7203 7204 7205 7206 7207 7208 |
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();
| | | 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 |
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 *)ckalloc(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 intrep of an iterator. We need
* to drop the refcount [Tcl Bug 9b352768e6].
|
| ︙ | ︙ | |||
7244 7245 7246 7247 7248 7249 7250 |
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
{
const Tcl_ObjIntRep *irPtr;
if (statePtr &&
(irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) {
| | | 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 |
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
{
const Tcl_ObjIntRep *irPtr;
if (statePtr &&
(irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) {
searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
} else {
Tcl_Panic("mis-issued dictNext!");
}
}
pushDictIteratorResult:
if (done) {
|
| ︙ | ︙ | |||
7276 7277 7278 7279 7280 7281 7282 |
JUMP_PEEPHOLE_F(done, 5, 0);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
| | | 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 |
JUMP_PEEPHOLE_F(done, 5, 0);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
7336 7337 7338 7339 7340 7341 7342 |
NEXT_INST_F(9, 0, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
| | | 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 |
NEXT_INST_F(9, 0, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
7513 7514 7515 7516 7517 7518 7519 |
case 3: /* seconds */
Tcl_GetTime(&now);
wval = (Tcl_WideInt) now.sec;
break;
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
| | | 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 |
case 3: /* seconds */
Tcl_GetTime(&now);
wval = (Tcl_WideInt) now.sec;
break;
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
TclNewIntObj(objResultPtr, wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
break;
default:
Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
|
| ︙ | ︙ | |||
7877 7878 7879 7880 7881 7882 7883 |
static int
FinalizeOONext(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 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 |
static int
FinalizeOONext(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
iPtr->varFramePtr = (CallFrame *)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[2]);
contextPtr->skip = PTR2INT(data[3]);
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeOONextFilter(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
iPtr->varFramePtr = (CallFrame *)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[2]);
|
| ︙ | ︙ | |||
8467 8468 8469 8470 8471 8472 8473 | return constants[1]; } WIDE_RESULT(-1); } /* * We refuse to accept exponent arguments that exceed one mp_digit | | | 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 |
return constants[1];
}
WIDE_RESULT(-1);
}
/*
* We refuse to accept exponent arguments that exceed one mp_digit
* which means the max exponent value is 2**28-1 = 0x0FFFFFFF =
* 268435455, which fits into a signed 32 bit int which is within the
* range of the long int type. This means any numeric Tcl_Obj value
* not using TCL_NUMBER_INT type must hold a value larger than we
* accept.
*/
if (type2 != TCL_NUMBER_INT) {
|
| ︙ | ︙ | |||
9280 9281 9282 9283 9284 9285 9286 |
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd - codePtr->source;
| | | 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 |
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
locPtr = eclPtr->loc+i;
break;
}
}
|
| ︙ | ︙ | |||
9645 9646 9647 9648 9649 9650 9651 | * None. * *---------------------------------------------------------------------- */ static int EvalStatsCmd( | | | 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 |
* None.
*
*----------------------------------------------------------------------
*/
static int
EvalStatsCmd(
TCL_UNUSED(void *), /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
ByteCodeStats *statsPtr = &iPtr->stats;
|
| ︙ | ︙ | |||
9668 9669 9670 9671 9672 9673 9674 |
int decadeHigh, length;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
#define Percent(a,b) ((a) * 100.0 / (b))
| | | 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 |
int decadeHigh, length;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
#define Percent(a,b) ((a) * 100.0 / (b))
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
numInstructions = 0.0;
for (i = 0; i < 256; i++) {
if (statsPtr->instructionCount[i] != 0) {
numInstructions += statsPtr->instructionCount[i];
}
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
1 2 3 4 5 6 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * * Copyright © 1996-1998 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 "tclFileSystem.h" |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileRenameCmd( | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileRenameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileCopyCmd( | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileCopyCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileMakeDirsCmd( | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileMakeDirsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
Tcl_Obj *errfile = NULL;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileDeleteCmd( | | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileDeleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
if ((objc == 1) &&
(Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
}
if (resultPtr == NULL) {
| | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
if ((objc == 1) &&
(Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
}
if (resultPtr == NULL) {
TclNewObj(resultPtr);
}
Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(splitPtr);
return resultPtr;
}
/*
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | * May set file attributes for the file name. * *---------------------------------------------------------------------- */ int TclFileAttrsCmd( | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
* May set file attributes for the file name.
*
*----------------------------------------------------------------------
*/
int
TclFileAttrsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
{
int result;
const char *const *attributeStrings;
const char **attributeStringsAllocated = NULL;
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, | | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
Tcl_SetObjResult(interp, objPtr);
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
| | | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 |
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", 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", NULL);
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | * May create a new link. * *---------------------------------------------------------------------- */ int TclFileLinkCmd( | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* May create a new link.
*
*----------------------------------------------------------------------
*/
int
TclFileLinkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
int index;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | * None. * *---------------------------------------------------------------------- */ int TclFileReadLinkCmd( | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclFileReadLinkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
if (objc != 2) {
|
| ︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 | * to a variable, so reentrancy is a potential issue. * *--------------------------------------------------------------------------- */ int TclFileTemporaryCmd( | | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 |
* to a variable, so reentrancy is a potential issue.
*
*---------------------------------------------------------------------------
*/
int
TclFileTemporaryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
* file in. */
Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 | * Creates a temporary directory. * *--------------------------------------------------------------------------- */ int TclFileTempDirCmd( | | | 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
* Creates a temporary directory.
*
*---------------------------------------------------------------------------
*/
int
TclFileTempDirCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirNameObj; /* Object that will contain the directory
* name. */
Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL;
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
1 2 3 4 5 6 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. * * Copyright © 1995-1998 Sun Microsystems, Inc. * 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" #include "tclRegexp.h" |
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
&& path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'com[1-9]:?', which is a serial port.
*/
if (path[4] == '\0') {
abs = 4;
| | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
&& path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'com[1-9]:?', which is a serial port.
*/
if (path[4] == '\0') {
abs = 4;
} else if (path[4] == ':' && path[5] == '\0') {
abs = 5;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
/*
* Have match for 'con'.
*/
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
if (path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'lpt[1-9]:?'
*/
if (path[4] == '\0') {
abs = 4;
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
if (path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'lpt[1-9]:?'
*/
if (path[4] == '\0') {
abs = 4;
} else if (path[4] == ':' && path[5] == '\0') {
abs = 5;
}
}
} else if ((path[0] == 'p' || path[0] == 'P')
&& (path[1] == 'r' || path[1] == 'R')
&& (path[2] == 'n' || path[2] == 'N')
|
| ︙ | ︙ | |||
583 584 585 586 587 588 589 |
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
* plus the argv pointers and the terminating NULL pointer.
*/
| > | | | 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 |
}
/*
* 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 **)ckalloc(
((((*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.
*/
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 |
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *origPath = path, *elementStart;
| | > | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *origPath = path, *elementStart;
Tcl_Obj *result;
/*
* Deal with the root directory as a special case.
*/
TclNewObj(result);
if (*path == '/') {
Tcl_Obj *rootElt;
++path;
#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
|
| ︙ | ︙ | |||
731 732 733 734 735 736 737 |
SplitWinPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *p, *elementStart;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
Tcl_DString buf;
| | > | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
SplitWinPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *p, *elementStart;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
Tcl_DString buf;
Tcl_Obj *result;
Tcl_DStringInit(&buf);
TclNewObj(result);
p = ExtractWinRoot(path, &buf, 0, &type);
/*
* Terminate the root portion, if we matched something.
*/
if (p != path) {
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 |
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
| | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *));
elemv[0] = pathPtr;
memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
ret = TclJoinPath(elemc, elemv, 0);
ckfree(elemv);
return ret;
}
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
int i, len;
| | > | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
int i, len;
Tcl_Obj *listObj;
Tcl_Obj *resultObj;
const char *resultStr;
/*
* Build the list of paths.
*/
TclNewObj(listObj);
for (i = 0; i < argc; i++) {
Tcl_ListObjAppendElement(NULL, listObj,
Tcl_NewStringObj(argv[i], -1));
}
/*
* Ask the objectified code to join the paths.
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int index, i, globFlags, length, join, dir, result;
char *string;
const char *separators;
Tcl_Obj *typePtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
static const char *const options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
enum globOptionsEnum {
GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
GLOB_TYPE, GLOB_LAST
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 | */ Tcl_ResetResult(interp); break; } } | | > > | > | 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 |
*/
Tcl_ResetResult(interp);
break;
}
}
switch ((enum globOptionsEnum) index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
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", 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", NULL);
return TCL_ERROR;
}
dir = PATH_DIR;
globFlags |= TCL_GLOBMODE_DIR;
pathOrDir = objv[i+1];
|
| ︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| > > | > | 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", 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", NULL);
return TCL_ERROR;
}
dir = PATH_GENERAL;
pathOrDir = objv[i+1];
i++;
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
| | | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
|
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 |
* platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
| | | 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 |
* platform.
*/
Tcl_ListObjLength(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) {
int len;
|
| ︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 | * * Side effects: * The 'pattern' is written to. * *---------------------------------------------------------------------- */ | < | | 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 |
*
* Side effects:
* The 'pattern' is written to.
*
*----------------------------------------------------------------------
*/
int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
* appending list of matching file names. */
char *pattern, /* Glob pattern to match. Must not refer to a
* static string. */
Tcl_Obj *pathPrefix, /* Path prefix to glob pattern, if non-null,
* which is considered literally. */
int globFlags, /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types) /* Struct containing acceptable types. May be
* NULL. */
{
const char *separators;
const char *head;
char *tail, *start;
int result;
Tcl_Obj *filenamesObj, *savedResultObj;
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
|
| ︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 | /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted | | | 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 | /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted * occurrence of the specified character at the same braces nesting level. * * Results: * Updates stringPtr to point to the matching character, or to the end of * the string if nothing matched. The return value is 1 if a match was * found at the top level, otherwise it is 0. * * Side effects: |
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 | /* * The current prefix must end in a separator. */ int len; const char *joined = TclGetStringFromObj(joinedPtr,&len); | | | 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 |
/*
* The current prefix must end in a separator.
*/
int 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));
}
Tcl_IncrRefCount(joinedPtr);
|
| ︙ | ︙ | |||
2480 2481 2482 2483 2484 2485 2486 | * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ int len; const char *joined = TclGetStringFromObj(joinedPtr,&len); | | | 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 |
* //machine/share/subdir *]' requires adding a separator here.
* This behaviour is not currently tested for in the test suite.
*/
int 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);
}
}
}
Tcl_AppendToObj(joinedPtr, pattern, p-pattern);
}
|
| ︙ | ︙ | |||
2518 2519 2520 2521 2522 2523 2524 |
*
*---------------------------------------------------------------------------
*/
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
| | | 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 |
*
*---------------------------------------------------------------------------
*/
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf));
}
/*
*---------------------------------------------------------------------------
*
* Access functions for Tcl_StatBuf --
*
|
| ︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 |
#else
unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
#endif
}
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
| > < > > > > > < > | 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 |
#else
unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
#endif
}
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
return statPtr->st_blksize;
}
#else
unsigned
Tcl_GetBlockSizeFromStat(
TCL_UNUSED(const Tcl_StatBuf *))
{
/*
* Not a great guess, but will do...
*/
return GUESSED_BLOCK_SIZE;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclGet.c.
1 2 3 4 5 6 7 | /* * tclGet.c -- * * This file contains functions to convert strings into other forms, like * integers or floating-point numbers or booleans, doing syntax checking * along the way. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclGet.c -- * * This file contains functions to convert strings into other forms, like * integers or floating-point numbers or booleans, doing syntax checking * along the way. * * Copyright © 1990-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ |
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 |
/*
* 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 (c) 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright (c) 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.
*/
%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 (c) 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright (c) 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"
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| < < < < < < < < < < < < < < < < < > > > > > > | 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 |
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
yyMeridian = $6;
}
;
zone : tZONE tDST {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
| tZONE {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
| tDAYZONE {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| sign tUNUMBER {
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
yyDSTmode = DSToff;
}
;
day : tDAY {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tDAY ',' {
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
| > > > > > > > > > > | | | | 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 |
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE
tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($6 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1;
yyMonth = $3;
yyDay = $5;
yyHour = $7;
yyMinutes = $9;
yySeconds = $11;
}
| tISOBASE tZONE tISOBASE {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3 / 10000;
yyMinutes = ($3 % 10000)/100;
yySeconds = $3 % 100;
}
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3;
yyMinutes = $5;
yySeconds = $7;
}
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
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";
}
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
| | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
TclNewObj(dateInfo.messages);
dateInfo.separatrix = "";
Tcl_IncrRefCount(dateInfo.messages);
status = yyparse(&dateInfo);
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 |
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
| | | | | | | | | 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 |
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
return TCL_ERROR;
}
TclNewObj(result);
TclNewObj(resultElement);
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int)
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
}
TclNewObj(resultElement);
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) -yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TcNewObj(resultElement);
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
|
| ︙ | ︙ |
Changes to generic/tclHash.c.
1 2 3 4 5 6 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright © 1991-1993 The Regents of the University of California. * Copyright © 1994 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" |
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
*/
Tcl_HashEntry *
Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key) /* Key to use to find matching entry. */
{
| | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
*/
Tcl_HashEntry *
Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key) /* Key to use to find matching entry. */
{
return (*((tablePtr)->findProc))(tablePtr, (const char *)key);
}
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
Tcl_CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
| | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
Tcl_CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
}
static Tcl_HashEntry *
CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key, /* Key to use to find or create matching
* entry. */
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
| | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
hPtr->clientData = 0;
}
hPtr->tablePtr = tablePtr;
hPtr->hash = UINT2PTR(hash);
hPtr->nextPtr = tablePtr->buckets[index];
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *)ckalloc((NUM_COUNTERS * 60) + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
sprintf(p, "number of buckets with %d entries: %d\n",
i, count[i]);
p += strlen(p);
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
count = tablePtr->keyType;
size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key);
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
| | | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
count = tablePtr->keyType;
size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key);
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
hPtr = (Tcl_HashEntry *)ckalloc(size);
for (iPtr1 = array, iPtr2 = hPtr->key.words;
count > 0; count--, iPtr1++, iPtr2++) {
*iPtr2 = *iPtr1;
}
hPtr->clientData = 0;
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
| | | | | | | 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 |
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
count--, array++) {
result += *array;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* AllocStringEntry --
*
* Allocate space for a Tcl_HashEntry containing the string key.
*
* Results:
* The return value is a pointer to the created entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
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 *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize);
memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key));
memcpy(hPtr->key.string, string, size);
hPtr->clientData = 0;
return hPtr;
}
/*
|
| ︙ | ︙ | |||
859 860 861 862 863 864 865 | * None. * *---------------------------------------------------------------------- */ static TCL_HASH_TYPE HashStringKey( | | | | | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 |
* None.
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashStringKey(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
const char *string = (const char *)keyPtr;
TCL_HASH_TYPE result;
char c;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
*/
if ((result = UCHAR(*string)) != 0) {
while ((c = *++string) != 0) {
result += (result << 3) + UCHAR(c);
}
}
| | < | | | 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 |
*/
if ((result = UCHAR(*string)) != 0) {
while ((c = *++string) != 0) {
result += (result << 3) + UCHAR(c);
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* BogusFind --
*
* This function is invoked when Tcl_FindHashEntry is called on a
* table that has been deleted.
*
* Results:
* If Tcl_Panic returns (which it shouldn't) this function returns NULL.
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
BogusFind(
TCL_UNUSED(Tcl_HashTable *),
TCL_UNUSED(const char *))
{
Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry");
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 | * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ | < | | | < < | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
BogusCreate(
TCL_UNUSED(Tcl_HashTable *),
TCL_UNUSED(const char *),
TCL_UNUSED(int *))
{
Tcl_Panic("called %s on deleted table", "Tcl_CreateHashEntry");
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc(
tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0);
} else {
tablePtr->buckets =
| | | 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 |
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc(
tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0);
} else {
tablePtr->buckets =
(Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
}
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->downShift -= 2;
|
| ︙ | ︙ |
Changes to generic/tclHistory.c.
1 2 3 4 5 6 7 8 |
/*
* tclHistory.c --
*
* This module and the Tcl library file history.tcl together implement
* Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
/*
* tclHistory.c --
*
* This module and the Tcl library file history.tcl together implement
* Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*
* Copyright © 1990-1993 The Regents of the University of California.
* Copyright © 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
| | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
(HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
Tcl_IncrRefCount(histObjsPtr->addObj);
Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
histObjsPtr);
}
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 |
*
*----------------------------------------------------------------------
*/
static void
DeleteHistoryObjs(
ClientData clientData,
| | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
*
*----------------------------------------------------------------------
*/
static void
DeleteHistoryObjs(
ClientData clientData,
TCL_UNUSED(Tcl_Interp *))
{
HistoryObjs *histObjsPtr = (HistoryObjs *)clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
ckfree(histObjsPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIO.c.
1 2 3 4 5 6 | /* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright © 1998-2000 Ajuba Solutions * Copyright © 1995-1997 Sun Microsystems, Inc. * Contributions from Don Porter, NIST, 2014. (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. */ #include "tclInt.h" |
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | int appendFlag); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); static Tcl_Encoding GetBinaryEncoding(void); | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | int appendFlag); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); static Tcl_Encoding GetBinaryEncoding(void); static Tcl_ExitProc FreeBinaryEncoding; static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, |
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) #define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) | | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) #define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) #define InsertPoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextAdded]) #define RemovePoint(bufPtr) (&(bufPtr)->buf[(bufPtr)->nextRemoved]) /* * For working with channel state flag bits. */ #define SetFlag(statePtr, flag) ((statePtr)->flags |= (flag)) #define ResetFlag(statePtr, flag) ((statePtr)->flags &= ~(flag)) |
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
} while (0)
#define ChanGetIntRep(objPtr, resPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &chanObjType); \
| | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
} while (0)
#define ChanGetIntRep(objPtr, resPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &chanObjType); \
(resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
*/
static inline int
ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
| > | < < < | < < < < < < | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
*/
static inline int
ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) {
return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp);
}
#endif
return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
/*
*---------------------------------------------------------------------------
*
* ChanRead --
*
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 |
int *errnoPtr)
{
/*
* Note that we prefer the wideSeekProc if that field is available in the
* type and non-NULL.
*/
| | | > | > | > | > | > | | | 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 |
int *errnoPtr)
{
/*
* Note that we prefer the wideSeekProc if that field is available in the
* type and non-NULL.
*/
if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
#ifndef TCL_NO_DEPRECATED
if (offset<LONG_MIN || offset>LONG_MAX) {
*errnoPtr = EOVERFLOW;
return -1;
}
return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
offset, mode, errnoPtr);
#else
*errnoPtr = EINVAL;
return -1;
#endif
}
return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
offset, mode, errnoPtr);
}
static inline void
ChanThreadAction(
Channel *chanPtr,
int action)
{
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 | * * Side effects: * Depends on encoding and memory subsystems. * *------------------------------------------------------------------------- */ | < | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
*
* Side effects:
* Depends on encoding and memory subsystems.
*
*-------------------------------------------------------------------------
*/
void
TclFinalizeIOSubsystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr = NULL; /* Iterates over open channels. */
ChannelState *statePtr; /* State of channel stack */
int active = 1; /* Flag == 1 while there's still work to do */
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
| | | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
cbPtr = (CloseCallback *)ckalloc(sizeof(CloseCallback));
cbPtr->proc = proc;
cbPtr->clientData = clientData;
cbPtr->nextPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr;
}
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
static Tcl_HashTable *
GetChannelTable(
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
| | | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
static Tcl_HashTable *
GetChannelTable(
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclIO",
(Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr);
/*
* If the interpreter is trusted (not "safe"), insert channels for
* stdin, stdout and stderr (possibly creating them in the process).
|
| ︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 |
* to the interpreter being deleted. */
/*
* Delete all the registered channels - this will close channels whose
* refcount reaches zero.
*/
| | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
* to the interpreter being deleted. */
/*
* Delete all the registered channels - this will close channels whose
* refcount reaches zero.
*/
hTblPtr = (Tcl_HashTable *)clientData;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
/*
* Remove any fileevents registered in this interpreter.
*/
for (sPtr = statePtr->scriptRecordPtr, prevPtr = NULL;
|
| ︙ | ︙ | |||
1372 1373 1374 1375 1376 1377 1378 |
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (interp != NULL) {
| | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (interp != NULL) {
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
/*
* 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.
*/
| | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 |
/*
* 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.
*/
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
*modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE);
}
return (Tcl_Channel) chanPtr;
}
|
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
* channel. */
Tcl_Obj *objPtr,
Tcl_Channel *channelPtr,
int *modePtr, /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
| | | | | 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 |
* channel. */
Tcl_Obj *objPtr,
Tcl_Channel *channelPtr,
int *modePtr, /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
TCL_UNUSED(int) /*flags*/)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
if (interp == NULL) {
return TCL_ERROR;
}
ChanGetIntRep(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.
*/
goto valid;
}
}
chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
* If this assertion fails on some system, then it can be removed only if
* the user recompiles code with older channel drivers in the new system
* as well.
*/
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
| > > > > > > > > | | > > | > | | | | | 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 |
* If this assertion fails on some system, then it can be removed only if
* the user recompiles code with older channel drivers in the new system
* as well.
*/
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
#ifndef TCL_NO_DEPRECATED
if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) {
Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName);
}
#else
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);
}
#endif
if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) {
Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName);
}
if ((TCL_WRITABLE & mask) && (NULL == typePtr->outputProc)) {
Tcl_Panic("channel type %s must define outputProc when used for writer channel", typePtr->typeName);
}
if (NULL == typePtr->watchProc) {
Tcl_Panic("channel type %s must define watchProc", typePtr->typeName);
}
#ifndef TCL_NO_DEPRECATED
if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName);
}
#endif
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
* assignments to 0/NULL below.
*/
chanPtr = (Channel *)ckalloc(sizeof(Channel));
statePtr = (ChannelState *)ckalloc(sizeof(ChannelState));
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
chanPtr->typePtr = typePtr;
/*
* Set all the bits that are part of the stack-independent state
* 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 *)ckalloc((len < 7) ? 7 : len);
strcpy(tmp, chanName);
} else {
tmp = (char *)ckalloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
/*
* Set the channel to system default encoding.
|
| ︙ | ︙ | |||
1938 1939 1940 1941 1942 1943 1944 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
| | | 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
chanPtr = (Channel *)ckalloc(sizeof(Channel));
/*
* Save some of the current state into the new structure, reinitialize the
* parts which will stay with the transformation.
*
* Remarks:
*/
|
| ︙ | ︙ | |||
2467 2468 2469 2470 2471 2472 2473 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
| | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *)ckalloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = NULL;
bufPtr->refCount = 1;
return bufPtr;
}
|
| ︙ | ︙ | |||
2873 2874 2875 2876 2877 2878 2879 |
*/
DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
break;
} else {
/*
| | | | 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 |
*/
DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
break;
} else {
/*
* TODO: Consider detecting and reacting to short writes on
* blocking channels. Ought not happen. See iocmd-24.2.
*/
wroteSome = 1;
}
bufPtr->nextRemoved += written;
/*
|
| ︙ | ︙ | |||
3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
| > > > | 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
|
| ︙ | ︙ | |||
3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
| > > > | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
|
| ︙ | ︙ | |||
3366 3367 3368 3369 3370 3371 3372 | * However, it may continue to exist for a while longer if it has a * background flush scheduled. The device itself is eventually closed and * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ | < | | 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 |
* However, it may continue to exist for a while longer if it has a
* background flush scheduled. The device itself is eventually closed and
* the channel record removed, in CloseChannel, above.
*
*----------------------------------------------------------------------
*/
int
Tcl_Close(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan) /* The channel being closed. Must not be
* referenced in any interpreter. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
int result = 0; /* Of calling FlushChannel. */
int flushcode;
int stickyError;
if (chan == NULL) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 |
ResetFlag(statePtr, CHANNEL_INCLOSE);
/*
* If this channel supports it, close the read side, since we don't need
* it anymore and this will help avoid deadlocks on some channel types.
*/
| > | > | < > > > > | > > > | 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 |
ResetFlag(statePtr, CHANNEL_INCLOSE);
/*
* If this channel supports it, close the read side, since we don't need
* it anymore and this will help avoid deadlocks on some channel types.
*/
#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) {
/* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
if ((result == EINVAL) || result == ENOTCONN) {
result = 0;
}
}
#else
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
if ((result == EINVAL) || result == ENOTCONN) {
result = 0;
}
#endif
/*
* 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.
*/
|
| ︙ | ︙ | |||
3526 3527 3528 3529 3530 3531 3532 |
}
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
*/
| | > > > > | | | | | < < < < < > > > > > > > > > > | | 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 |
}
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
*/
if (flushcode != 0) {
/* flushcode has precedence, if available */
result = flushcode;
}
if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
&& 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
Tcl_SetErrno(result);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
if (result != 0) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CloseEx --
*
* Closes one side of a channel, read or write, close all.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Closes one direction of the channel, or do a full close.
*
* NOTE:
* Tcl_CloseEx closes the specified direction of the channel as far as
* the user is concerned. If flags = 0, this is equivalent to Tcl_Close.
*
*----------------------------------------------------------------------
*/
int
Tcl_CloseEx(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan, /* The channel being closed. May still be used
* by some interpreter. */
int flags) /* Flags telling us which side to close. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
if (chan == NULL) {
return TCL_OK;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((flags & (TCL_READABLE | TCL_WRITABLE)) == 0) {
return Tcl_Close(interp, chan);
}
if ((flags & (TCL_READABLE | TCL_WRITABLE)) == (TCL_READABLE | TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"double-close of channels not supported by %ss",
chanPtr->typePtr->typeName));
return TCL_ERROR;
}
/*
* Does the channel support half-close anyway? Error if not.
*/
if (!chanPtr->typePtr->close2Proc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"half-close of channels not supported by %ss",
chanPtr->typePtr->typeName));
return TCL_ERROR;
}
/*
* Is the channel unstacked ? If not we fail.
*/
|
| ︙ | ︙ | |||
3822 3823 3824 3825 3826 3827 3828 |
/*
* Finally do what is asked of us. Close and free the channel driver state
* for the chosen side of the channel. This may leave a TIP #219 error
* message in the interp.
*/
| | | 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 |
/*
* Finally do what is asked of us. Close and free the channel driver state
* for the chosen side of the channel. This may leave a TIP #219 error
* message in the interp.
*/
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, NULL, flags);
/*
* If we are being called synchronously, report either any latent error on
* the channel or the current error.
*/
if (statePtr->unreportedError != 0) {
|
| ︙ | ︙ | |||
4208 4209 4210 4211 4212 4213 4214 |
static void
WillWrite(
Channel *chanPtr)
{
int inputBuffered;
| > > | > | | | | | | | > > | > | | | | | 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 |
static void
WillWrite(
Channel *chanPtr)
{
int inputBuffered;
if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
#ifndef TCL_NO_DEPRECATED
|| (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
#endif
) && ((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)
#ifndef TCL_NO_DEPRECATED
|| (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
#endif
) && (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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4294 4295 4296 4297 4298 4299 4300 |
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
| | | 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 |
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
nextNewLine = (char *)memchr(src, '\n', srcLen);
}
while (srcLen + saved + endEncoding > 0) {
ChannelBuffer *bufPtr;
char *dst, safe[BUFFER_PADDING];
int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
|
| ︙ | ︙ | |||
4332 4333 4334 4335 4336 4337 4338 | result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); /* | | | | | | 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 |
result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
statePtr->outputEncodingFlags,
&statePtr->outputEncodingState, dst,
dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
/*
* See chan-io-1.[89]. Tcl Bug 506297.
*/
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
/*
* We're reading from invalid/incomplete UTF-8.
*/
ReleaseChannelBuffer(bufPtr);
if (total == 0) {
Tcl_SetErrno(EINVAL);
return -1;
}
break;
|
| ︙ | ︙ | |||
4392 4393 4394 4395 4396 4397 4398 | bufPtr->nextAdded += dstWrote; src++; srcLen--; total += dstWrote; dst += dstWrote; dstLen -= dstWrote; | | | 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 |
bufPtr->nextAdded += dstWrote;
src++;
srcLen--;
total += dstWrote;
dst += dstWrote;
dstLen -= dstWrote;
nextNewLine = (char *)memchr(src, '\n', srcLen);
needNlFlush = 1;
}
if (IsBufferOverflowing(bufPtr)) {
/*
* When translating from UTF-8 to external encoding, we allowed
* the translation to produce a character that crossed the end of
|
| ︙ | ︙ | |||
4717 4718 4719 4720 4721 4722 4723 | gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, sizeof(tmp), &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; gs.charsWrote--; | | | 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 |
gs.rawRead, statePtr->inputEncodingFlags
| TCL_ENCODING_NO_TERMINATE, &gs.state, tmp,
sizeof(tmp), &rawRead, NULL, NULL);
bufPtr->nextRemoved += rawRead;
gs.rawRead -= rawRead;
gs.bytesWrote--;
gs.charsWrote--;
memmove(dst, dst + 1, dstEnd - dst);
dstEnd--;
}
}
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
eol++;
if (eol == dstEnd) {
|
| ︙ | ︙ | |||
5191 5192 5193 5194 5195 5196 5197 | * None. * *--------------------------------------------------------------------------- */ static void FreeBinaryEncoding( | | | | 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 |
* None.
*
*---------------------------------------------------------------------------
*/
static void
FreeBinaryEncoding(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
tsdPtr->binaryEncoding = NULL;
}
}
static Tcl_Encoding
GetBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->binaryEncoding == NULL) {
tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL);
}
|
| ︙ | ︙ | |||
5651 5652 5653 5654 5655 5656 5657 |
while (chanPtr->inQueueHead && bytesToRead > 0) {
ChannelBuffer *bufPtr = chanPtr->inQueueHead;
int bytesInBuffer = BytesLeft(bufPtr);
int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer
: bytesToRead;
/*
| | | | 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 |
while (chanPtr->inQueueHead && bytesToRead > 0) {
ChannelBuffer *bufPtr = chanPtr->inQueueHead;
int bytesInBuffer = BytesLeft(bufPtr);
int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer
: bytesToRead;
/*
* Copy the current chunk into the read buffer.
*/
memcpy(readBuf, RemovePoint(bufPtr), toCopy);
bufPtr->nextRemoved += toCopy;
copied += toCopy;
readBuf += toCopy;
bytesToRead -= toCopy;
|
| ︙ | ︙ | |||
5693 5694 5695 5696 5697 5698 5699 |
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
/*
| | | | 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 |
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
/*
* Successful read (short is OK) - add to bytes copied.
*/
copied += nread;
} else if (nread < 0) {
/*
* An error signaled. If CHANNEL_BLOCKED, then the error is not
* real, but an indication of blocked state. In that case, retain
* the flag and let caller receive the short read of copied bytes
|
| ︙ | ︙ | |||
5823 5824 5825 5826 5827 5828 5829 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
binaryMode = (encoding == NULL)
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
| | > > > > | 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
binaryMode = (encoding == NULL)
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
if (appendFlag) {
if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) {
binaryMode = 0;
}
} else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
Tcl_SetObjLength(objPtr, 0);
/*
* We're going to access objPtr->bytes directly, so we must ensure
|
| ︙ | ︙ | |||
6345 6346 6347 6348 6349 6350 6351 |
continue;
}
if (dstWrote == 0) {
ChannelBuffer *nextPtr;
/*
| | | | | 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 |
continue;
}
if (dstWrote == 0) {
ChannelBuffer *nextPtr;
/*
* We were not able to read any chars.
*/
assert(numChars == 0);
/*
* There is one situation where this is the correct final result.
* If the src buffer contains only a single \n byte, and we are in
* TCL_TRANSLATE_AUTO mode, and when the translation pass was made
* the INPUT_SAW_CR flag was set on the channel. In that case, the
* correct behavior is to consume that \n and produce the empty
* string.
*/
if (dstRead == 1 && dst[0] == '\n') {
assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO);
goto consume;
}
/*
* Otherwise, reading zero characters indicates there's something
* incomplete at the end of the src buffer. Maybe there were not
* enough src bytes to decode into a char. Maybe a lone \r could
* not be translated (crlf mode). Need to combine any unused src
* bytes we have in the first buffer with subsequent bytes to try
* again.
*/
|
| ︙ | ︙ | |||
6475 6476 6477 6478 6479 6480 6481 |
* This keeps the scan for eof char below from being pointlessly long.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (srcLen > dstLen) {
| | | | | | | | | | 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 |
* This keeps the scan for eof char below from being pointlessly long.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (srcLen > dstLen) {
/*
* In these modes, each src byte become a dst byte.
*/
srcLen = dstLen;
}
break;
default:
/*
* In other modes, at most 2 src bytes become a dst byte.
*/
if (srcLen/2 > dstLen) {
srcLen = 2 * dstLen;
}
break;
}
if (inEofChar != '\0') {
/*
* Make sure we do not read past any logical end of channel input
* created by the presence of the input eof char.
*/
if ((eof = (const char *)memchr(srcStart, inEofChar, srcLen))) {
srcLen = eof - srcStart;
}
}
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (dstStart != srcStart) {
memcpy(dstStart, srcStart, srcLen);
}
if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
char *dst = dstStart;
char *dstEnd = dstStart + srcLen;
while ((dst = (char *)memchr(dst, '\r', dstEnd - dst))) {
*dst++ = '\n';
}
}
dstLen = srcLen;
break;
case TCL_TRANSLATE_CRLF: {
const char *crFound, *src = srcStart;
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 */
|
| ︙ | ︙ | |||
6565 6566 6567 6568 6569 6570 6571 |
int lesser;
if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
if (*src == '\n') { src++; srcLen--; }
ResetFlag(statePtr, INPUT_SAW_CR);
}
lesser = (dstLen < srcLen) ? dstLen : srcLen;
| | | 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 |
int lesser;
if ((statePtr->flags & 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) {
|
| ︙ | ︙ | |||
6990 6991 6992 6993 6994 6995 6996 |
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.
*/
| > > | > > | 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 |
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)
#ifndef TCL_NO_DEPRECATED
&& (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
#endif
) {
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.
|
| ︙ | ︙ | |||
7154 7155 7156 7157 7158 7159 7160 |
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.
*/
| > > | > > | 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 |
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)
#ifndef TCL_NO_DEPRECATED
&& (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
#endif
) {
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.
|
| ︙ | ︙ | |||
7660 7661 7662 7663 7664 7665 7666 |
}
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 ",
| | | 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 |
}
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);
|
| ︙ | ︙ | |||
8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
| > > > > > > > | 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* Avoid processing if the channel owner has been changed.
*/
if (statePtr->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
|
| ︙ | ︙ | |||
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 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
| > > > > > > > > | 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 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
/*
* Stop if the channel owner has been changed in-between.
*/
if (chanPtr->state->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
done:
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
|
| ︙ | ︙ | |||
8537 8538 8539 8540 8541 8542 8543 |
*----------------------------------------------------------------------
*/
static void
ChannelTimerProc(
ClientData clientData)
{
| | | 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 |
*----------------------------------------------------------------------
*/
static void
ChannelTimerProc(
ClientData clientData)
{
Channel *chanPtr = (Channel *)clientData;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
Tcl_Preserve(statePtr);
statePtr->timer = NULL;
if (statePtr->interestMask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
|
| ︙ | ︙ | |||
8625 8626 8627 8628 8629 8630 8631 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
| | | 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
chPtr = (ChannelHandler *)ckalloc(sizeof(ChannelHandler));
chPtr->mask = 0;
chPtr->proc = proc;
chPtr->clientData = clientData;
chPtr->chanPtr = chanPtr;
chPtr->nextPtr = statePtr->chPtr;
statePtr->chPtr = chPtr;
}
|
| ︙ | ︙ | |||
8837 8838 8839 8840 8841 8842 8843 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
| | | 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
}
/*
* Initialize the structure before calling Tcl_CreateChannelHandler,
* because a reflected channel calling 'chan postevent' aka
* 'Tcl_NotifyChannel' in its 'watch'Proc will invoke
* 'TclChannelEventScriptInvoker' immediately, and we do not wish it to
|
| ︙ | ︙ | |||
8884 8885 8886 8887 8888 8889 8890 |
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(
ClientData clientData, /* The script+interp record. */
| | > | > > | > | | < > > > | < < | 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 |
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(
ClientData clientData, /* The script+interp record. */
TCL_UNUSED(int) /*mask*/)
{
EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
/* The event script + interpreter to eval it
* in. */
Channel *chanPtr = esPtr->chanPtr;
/* The channel for which this handler is
* registered. */
Tcl_Interp *interp = esPtr->interp;
/* Interpreter in which to eval the script. */
int mask = esPtr->mask;
int result; /* Result of call to eval script. */
/*
* Be sure event executed in managed channel (covering bugs similar [f583715154]).
*/
assert(chanPtr->state->managingThread == Tcl_GetCurrentThread());
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
|
| ︙ | ︙ | |||
8945 8946 8947 8948 8949 8950 8951 | * * Side effects: * May create a channel handler for the specified channel. * *---------------------------------------------------------------------- */ | < | | 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 |
*
* Side effects:
* May create a channel handler for the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FileEventObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Channel *chanPtr; /* The channel to create the handler for. */
ChannelState *statePtr; /* State info for channel */
|
| ︙ | ︙ | |||
9047 9048 9049 9050 9051 9052 9053 |
static void
ZeroTransferTimerProc(
ClientData clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
*/
| | | 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 |
static void
ZeroTransferTimerProc(
ClientData clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
*/
CopyData((CopyState *)clientData, 0);
}
/*
*----------------------------------------------------------------------
*
* TclCopyChannel --
*
|
| ︙ | ︙ | |||
9167 9168 9169 9170 9171 9172 9173 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
| | | 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
csPtr->total = (Tcl_WideInt) 0;
|
| ︙ | ︙ | |||
9579 9580 9581 9582 9583 9584 9585 |
}
Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc,
csPtr);
}
if (size == 0) {
if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
/*
| | | | 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 |
}
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;
}
|
| ︙ | ︙ | |||
9863 9864 9865 9866 9867 9868 9869 |
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
assert(bufPtr != NULL);
if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
/*
| | | | | | 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 |
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
assert(bufPtr != NULL);
if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
/*
* Further reads cannot do any more.
*/
break;
}
if (code) {
/*
* Read error
*/
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return -1;
}
assert(IsBufferFull(bufPtr));
|
| ︙ | ︙ | |||
9924 9925 9926 9927 9928 9929 9930 |
assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
assert(RemovePoint(bufPtr)[0] == '\r');
assert(BytesLeft(bufPtr) == 1);
if (bufPtr->nextPtr == NULL) {
/*
| | | | | | | | | | | | 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 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 |
assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
assert(RemovePoint(bufPtr)[0] == '\r');
assert(BytesLeft(bufPtr) == 1);
if (bufPtr->nextPtr == NULL) {
/*
* There's no more buffered data...
*/
if (statePtr->flags & CHANNEL_EOF) {
/*
* ...and there never will be.
*/
*p++ = '\r';
bytesToRead--;
bufPtr->nextRemoved++;
} else if (statePtr->flags & CHANNEL_BLOCKED) {
/*
* ...and we cannot get more now.
*/
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
break;
} else {
/*
* ...so we need to get some.
*/
goto moreData;
}
}
if (bufPtr->nextPtr) {
/*
* There's a next buffer. Shift orphan \r to it.
*/
ChannelBuffer *nextPtr = bufPtr->nextPtr;
nextPtr->nextRemoved -= 1;
RemovePoint(nextPtr)[0] = '\r';
bufPtr->nextRemoved++;
}
|
| ︙ | ︙ | |||
10025 10026 10027 10028 10029 10030 10031 |
*/
static void
CopyEventProc(
ClientData clientData,
int mask)
{
| | | 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 |
*/
static void
CopyEventProc(
ClientData clientData,
int mask)
{
(void) CopyData((CopyState *)clientData, mask);
}
/*
*----------------------------------------------------------------------
*
* StopCopy --
*
|
| ︙ | ︙ | |||
10358 10359 10360 10361 10362 10363 10364 |
* Always check bottom-most channel in the stack. This is the one that
* gets registered.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
| | | 10423 10424 10425 10426 10427 10428 10429 10430 10431 10432 10433 10434 10435 10436 10437 |
* Always check bottom-most channel in the stack. This is the one that
* gets registered.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return 0;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == NULL) {
return 0;
}
|
| ︙ | ︙ | |||
10440 10441 10442 10443 10444 10445 10446 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
| | | 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
(memcmp(name, chanName, chanNameLen + 1) == 0)) {
return 1;
}
}
return 0;
}
|
| ︙ | ︙ | |||
10492 10493 10494 10495 10496 10497 10498 10499 10500 10501 10502 10503 10504 10505 10506 10507 10508 10509 10510 10511 10512 10513 |
*/
Tcl_ChannelTypeVersion
Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2)
|| (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) {
/*
* In <v2 channel versions, the version field is occupied by the
* Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
}
return chanTypePtr->version;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelBlockModeProc --
| > > | 10557 10558 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 10574 10575 10576 10577 10578 10579 10580 |
*/
Tcl_ChannelTypeVersion
Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2)
|| (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) {
/*
* In <v2 channel versions, the version field is occupied by the
* Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
}
#endif
return chanTypePtr->version;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelBlockModeProc --
|
| ︙ | ︙ | |||
10523 10524 10525 10526 10527 10528 10529 10530 10531 10532 10533 10534 10535 |
*---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
| > | > > | 10590 10591 10592 10593 10594 10595 10596 10597 10598 10599 10600 10601 10602 10603 10604 10605 10606 10607 10608 10609 10610 10611 10612 10613 10614 10615 10616 10617 10618 10619 10620 10621 10622 10623 10624 10625 10626 10627 10628 10629 10630 10631 10632 10633 10634 10635 10636 10637 10638 10639 |
*---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
#endif
return chanTypePtr->blockModeProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelCloseProc --
*
* Return the Tcl_DriverCloseProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->closeProc;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelClose2Proc --
*
* Return the Tcl_DriverClose2Proc of the channel type.
|
| ︙ | ︙ | |||
10645 10646 10647 10648 10649 10650 10651 10652 10653 10654 10655 10656 10657 10658 10659 10660 10661 10662 10663 10664 10665 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->seekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSetOptionProc --
*
* Return the Tcl_DriverSetOptionProc of the channel type.
| > > | 10715 10716 10717 10718 10719 10720 10721 10722 10723 10724 10725 10726 10727 10728 10729 10730 10731 10732 10733 10734 10735 10736 10737 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->seekProc;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSetOptionProc --
*
* Return the Tcl_DriverSetOptionProc of the channel type.
|
| ︙ | ︙ | |||
10770 10771 10772 10773 10774 10775 10776 10777 10778 10779 10780 10781 10782 10783 10784 10785 10786 |
*/
Tcl_DriverFlushProc *
Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
return chanTypePtr->flushProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelHandlerProc --
| > > | 10842 10843 10844 10845 10846 10847 10848 10849 10850 10851 10852 10853 10854 10855 10856 10857 10858 10859 10860 |
*/
Tcl_DriverFlushProc *
Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
#endif
return chanTypePtr->flushProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelHandlerProc --
|
| ︙ | ︙ | |||
10797 10798 10799 10800 10801 10802 10803 10804 10805 10806 10807 10808 10809 10810 10811 10812 10813 |
*/
Tcl_DriverHandlerProc *
Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
return chanTypePtr->handlerProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelWideSeekProc --
| > > | 10871 10872 10873 10874 10875 10876 10877 10878 10879 10880 10881 10882 10883 10884 10885 10886 10887 10888 10889 |
*/
Tcl_DriverHandlerProc *
Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
#endif
return chanTypePtr->handlerProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelWideSeekProc --
|
| ︙ | ︙ | |||
10824 10825 10826 10827 10828 10829 10830 10831 10832 10833 10834 10835 10836 10837 10838 10839 10840 |
*/
Tcl_DriverWideSeekProc *
Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) {
return NULL;
}
return chanTypePtr->wideSeekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelThreadActionProc --
| > > | 10900 10901 10902 10903 10904 10905 10906 10907 10908 10909 10910 10911 10912 10913 10914 10915 10916 10917 10918 |
*/
Tcl_DriverWideSeekProc *
Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) {
return NULL;
}
#endif
return chanTypePtr->wideSeekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelThreadActionProc --
|
| ︙ | ︙ | |||
10852 10853 10854 10855 10856 10857 10858 10859 10860 10861 10862 10863 10864 10865 10866 10867 10868 |
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) {
return NULL;
}
return chanTypePtr->threadActionProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetChannelErrorInterp --
| > > | 10930 10931 10932 10933 10934 10935 10936 10937 10938 10939 10940 10941 10942 10943 10944 10945 10946 10947 10948 |
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) {
return NULL;
}
#endif
return chanTypePtr->threadActionProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetChannelErrorInterp --
|
| ︙ | ︙ | |||
11032 11033 11034 11035 11036 11037 11038 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
| | | | | 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 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *));
/*
* New level/code information is spliced into the first occurence of
* -level, -code, further occurences are ignored. The options cannot be
* not present, we would not come here. Options which are ok are simply
* copied over.
*/
lignore = cignore = 0;
for (i=0, j=0; i<numOptions; i+=2) {
if (0 == strcmp(TclGetString(lv[i]), "-level")) {
if (newlevel >= 0) {
lvn[j++] = lv[i];
lvn[j++] = Tcl_NewWideIntObj(newlevel);
newlevel = -1;
lignore = 1;
continue;
} else if (lignore) {
continue;
}
} else if (0 == strcmp(TclGetString(lv[i]), "-code")) {
if (newcode >= 0) {
lvn[j++] = lv[i];
lvn[j++] = Tcl_NewWideIntObj(newcode);
newcode = -1;
cignore = 1;
continue;
} else if (cignore) {
continue;
}
}
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed from
* the buffer. */
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
| | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
int nextAdded; /* The next position into which a character
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed from
* the buffer. */
int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
* buffer occuppies this space + bufSize-1
* bytes. This must be the last field in the
* structure. */
} ChannelBuffer;
#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
1 2 3 4 5 | /* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * 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" |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | static Tcl_ThreadDataKey dataKey; /* * Static functions for this file: */ | | | | < < | > | < < | | < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | 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(ClientData callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); /* *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | * None. * *---------------------------------------------------------------------- */ static void FinalizeIOCmdTSD( | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeIOCmdTSD(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdoutObjPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->stdoutObjPtr);
tsdPtr->stdoutObjPtr = NULL;
}
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | * * Side effects: * Produces output on a channel. * *---------------------------------------------------------------------- */ | < | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
*
* Side effects:
* Produces output on a channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_PutsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
Tcl_Obj *string; /* String to write. */
Tcl_Obj *chanObjPtr = NULL; /* channel object. */
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 | * * Side effects: * May cause output to appear on the specified channel. * *---------------------------------------------------------------------- */ | < | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
*
* Side effects:
* May cause output to appear on the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FlushObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *chanObjPtr;
Tcl_Channel chan; /* The channel to flush on. */
int mode;
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 | * * Side effects: * May consume input from channel. * *---------------------------------------------------------------------- */ | < | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"channel \"%s\" wasn't opened for reading",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
/*
* TIP #219.
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
goto done;
}
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
code = TCL_ERROR;
goto done;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(lineLen));
} else {
Tcl_SetObjResult(interp, linePtr);
}
done:
TclChannelRelease(chan);
return code;
}
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 | * * Side effects: * May consume input from channel. * *---------------------------------------------------------------------- */ | < | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
}
}
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
}
}
TclNewObj(resultPtr);
Tcl_IncrRefCount(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 | * Side effects: * Moves the position of the access point on the specified channel. May * flush queued output. * *---------------------------------------------------------------------- */ | < | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
* Side effects:
* Moves the position of the access point on the specified channel. May
* flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_SeekObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt offset; /* Where to seek? */
int mode; /* How to seek? */
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_TellObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
int code;
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 | * * Side effects: * May discard queued input; may flush queued output. * *---------------------------------------------------------------------- */ | < | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
*
* Side effects:
* May discard queued input; may flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_CloseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
static const char *const dirOptions[] = {
"read", "write", NULL
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 | * * Side effects: * May modify the behavior of an IO channel. * *---------------------------------------------------------------------- */ | < | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
*
* Side effects:
* May modify the behavior of an IO channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FconfigureObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
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. */
|
| ︙ | ︙ | |||
840 841 842 843 844 845 846 | * Side effects: * Sets interp's result to boolean true or false depending on whether the * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ | < | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
* Side effects:
* Sets interp's result to boolean true or false depending on whether the
* specified channel has an EOF condition.
*
*---------------------------------------------------------------------------
*/
int
Tcl_EofObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
|
| ︙ | ︙ | |||
880 881 882 883 884 885 886 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExecObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum execOptionsEnum {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
/*
* Check for any leading option arguments.
*/
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 |
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
argv = (const char **)TclStackAlloc(interp, (argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
|
| ︙ | ︙ | |||
985 986 987 988 989 990 991 |
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
TclNewObj(resultPtr);
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 | * Side effects: * Sets interp's result to boolean true or false depending on whether the * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ | < | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
* Side effects:
* Sets interp's result to boolean true or false depending on whether the
* preceeding input operation on the channel would have blocked.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FblockedObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_OpenObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
1219 1220 1221 1222 1223 1224 1225 | * Deallocates memory and sets the interp field of all the accept * callback records to NULL to prevent this interpreter from being used * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ | < | | | | 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 |
* Deallocates memory and sets the interp field of all the accept
* callback records to NULL to prevent this interpreter from being used
* subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
static void
TcpAcceptCallbacksDeleteProc(
ClientData clientData, /* Data which was passed when the assocdata
* was registered. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
Tcl_DeleteHashTable(hTblPtr);
ckfree(hTblPtr);
}
|
| ︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 |
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to
* smash when the interpreter will be
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
| | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to
* smash when the interpreter will be
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
}
hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew);
if (!isNew) {
|
| ︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 |
AcceptCallback *acceptCallbackPtr)
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
| | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 |
AcceptCallback *acceptCallbackPtr)
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 |
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
| | | | 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 |
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
* away, this is signalled by setting the interp field of the callback
* data to NULL.
*/
if (acceptCallbackPtr->interp != NULL) {
Tcl_Interp *interp = acceptCallbackPtr->interp;
Tcl_Obj *script, *objv[2];
int result = TCL_OK;
objv[0] = acceptCallbackPtr->script;
objv[1] = Tcl_NewListObj(3, NULL);
Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(
Tcl_GetChannelName(chan), -1));
Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1));
Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewWideIntObj(port));
script = Tcl_ConcatObj(2, objv);
Tcl_IncrRefCount(script);
Tcl_DecrRefCount(objv[1]);
Tcl_Preserve(interp);
Tcl_RegisterChannel(interp, chan);
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 |
*/
static void
TcpServerCloseProc(
ClientData callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
| | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
*/
static void
TcpServerCloseProc(
ClientData callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
Tcl_DecrRefCount(acceptCallbackPtr->script);
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 | * Creates a socket based channel. * *---------------------------------------------------------------------- */ int Tcl_SocketObjCmd( | | | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
* Creates a socket based channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_SocketObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
"-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
NULL
};
enum socketOptionsEnum {
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT,
SKT_SERVER
};
int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1,
reusea = -1;
unsigned int flags = 0;
const char *host, *port, *myaddr = NULL;
|
| ︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 |
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 |
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptionsEnum) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot set -async option for server sockets", -1));
return TCL_ERROR;
}
async = 1;
|
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
| | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback));
Tcl_IncrRefCount(script);
acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServerEx(interp, port, host, flags,
AcceptCallbackProc, acceptCallbackPtr);
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 | * handler. * *---------------------------------------------------------------------- */ int Tcl_FcopyObjCmd( | | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
* handler.
*
*----------------------------------------------------------------------
*/
int
Tcl_FcopyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel inChan, outChan;
int mode, i, index;
Tcl_WideInt toRead;
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 | * Sets interp's result to the number of bytes of buffered input or * output (depending on whether the first argument is "input" or * "output"), or -1 if the channel wasn't opened for that mode. * *--------------------------------------------------------------------------- */ | < | | | | | | | | 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 |
* Sets interp's result to the number of bytes of buffered input or
* output (depending on whether the first argument is "input" or
* "output"), or -1 if the channel wasn't opened for that mode.
*
*---------------------------------------------------------------------------
*/
static int
ChanPendingObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int index, mode;
static const char *const options[] = {"input", "output", NULL};
enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT};
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum pendingOptionsEnum) index) {
case PENDING_INPUT:
if (!(mode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
if (!(mode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan)));
}
break;
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 | * Truncates a channel (or rather a file underlying a channel). * *---------------------------------------------------------------------- */ static int ChanTruncateObjCmd( | | | 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
* Truncates a channel (or rather a file underlying a channel).
*
*----------------------------------------------------------------------
*/
static int
ChanTruncateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
Tcl_WideInt length;
|
| ︙ | ︙ | |||
1947 1948 1949 1950 1951 1952 1953 | * anonymous pipe. * *---------------------------------------------------------------------- */ static int ChanPipeObjCmd( | | | | 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 |
* anonymous pipe.
*
*----------------------------------------------------------------------
*/
static int
ChanPipeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel rchan, wchan;
const char *channelNames[2];
Tcl_Obj *resultPtr;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) {
return TCL_ERROR;
}
channelNames[0] = Tcl_GetChannelName(rchan);
channelNames[1] = Tcl_GetChannelName(wchan);
TclNewObj(resultPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(channelNames[0], -1));
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(channelNames[1], -1));
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 | * None. * *---------------------------------------------------------------------- */ int TclChannelNamesCmd( | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclChannelNamesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
1 2 3 4 5 6 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API at the * script level. Contributed by Andreas Kupries. * | | | | > > | 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 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API at the * script level. Contributed by Andreas Kupries. * * Copyright © 2000 Ajuba Solutions * Copyright © 1999-2000 Andreas Kupries (a.kupries@westend.com) * * 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" /* * Forward declarations of internal procedures. First the driver procedures of * the transformation. */ static int TransformBlockModeProc(ClientData instanceData, int mode); static int TransformCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int TransformInputProc(ClientData instanceData, char *buf, int toRead, int *errorCodePtr); static int TransformOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); #ifndef TCL_NO_DEPRECATED static int TransformSeekProc(ClientData instanceData, long offset, int mode, int *errorCodePtr); #endif static int TransformSetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); static int TransformGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void TransformWatchProc(ClientData instanceData, int mask); |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | > > > > | | 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 |
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
TransformSeekProc, /* Seek proc. */
#else
NULL, /* Seek proc. */
#endif
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
TransformGetFileHandleProc, /* Get OS handles out of channel. */
TransformCloseProc, /* close2proc */
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up. */
TransformWideSeekProc, /* Wide seek proc. */
NULL, /* Thread action. */
NULL /* Truncate. */
};
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclChannelTransform(
Tcl_Interp *interp, /* Interpreter for result. */
Tcl_Channel chan, /* Channel to transform. */
Tcl_Obj *cmdObjPtr) /* Script to use for transform. */
{
Channel *chanPtr; /* The actual channel. */
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
/*
* Now initialize the transformation state and stack it upon the specified
* channel. One of the necessary things to do is to retrieve the blocking
* regime of the underlying channel and to use the same for us too.
*/
| | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
/*
* Now initialize the transformation state and stack it upon the specified
* channel. One of the necessary things to do is to retrieve the blocking
* regime of the underlying channel and to use the same for us too.
*/
dataPtr = (TransformChannelData *)ckalloc(sizeof(TransformChannelData));
dataPtr->refCount = 1;
Tcl_DStringInit(&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
dataPtr->readIsFlushed = 0;
dataPtr->eofPending = 0;
dataPtr->flags = 0;
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
*/
static int
TransformBlockModeProc(
ClientData instanceData, /* State of transformation. */
int mode) /* New blocking mode. */
{
| | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
*/
static int
TransformBlockModeProc(
ClientData instanceData, /* State of transformation. */
int mode) /* New blocking mode. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
dataPtr->flags |= CHANNEL_ASYNC;
} else {
dataPtr->flags &= ~CHANNEL_ASYNC;
}
return 0;
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
*
*----------------------------------------------------------------------
*/
static int
TransformCloseProc(
ClientData instanceData,
| | > | > > > > | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
*
*----------------------------------------------------------------------
*/
static int
TransformCloseProc(
ClientData instanceData,
Tcl_Interp *interp,
int flags)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Important: In this procedure 'dataPtr->self' already points to the
* underlying channel.
*
* There is no need to cancel an existing channel handler, this is already
* done. Either by 'Tcl_UnstackChannel' or by the general cleanup in
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
static int
TransformInputProc(
ClientData instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
static int
TransformInputProc(
ClientData instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
int gotBytes, read, copied;
Tcl_Channel downChan;
/*
* Should assert(dataPtr->mode & TCL_READABLE);
*/
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 |
static int
TransformOutputProc(
ClientData instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
static int
TransformOutputProc(
ClientData instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
/*
* Should assert(dataPtr->mode & TCL_WRITABLE);
*/
if (toWrite == 0) {
/*
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
* Result:
* -1 if failed, the new position if successful. An output argument
* contains the POSIX error code if an error occurred, or zero.
*
*----------------------------------------------------------------------
*/
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
| > | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
* Result:
* -1 if failed, the new position if successful. An output argument
* contains the POSIX error code if an error occurred, or zero.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
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_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformWideSeekProc --
*
* This procedure is called by the generic IO level to move the access
| > | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* TransformWideSeekProc --
*
* This procedure is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 |
static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
Tcl_WideInt offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
| | > > < | > | > > > > > | 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 |
static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
Tcl_WideInt 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);
#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
#endif
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
#ifndef TCL_NO_DEPRECATED
} else if (parentSeekProc) {
return parentSeekProc(parentData, 0, mode, errorCodePtr);
#endif
} else {
*errorCodePtr = EINVAL;
return -1;
}
}
/*
* It is a real request to change the position. Flush all data waiting for
* output and discard everything in the input buffers. Then pass the
* request down, unchanged.
*/
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
}
ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
*/
| | < < < | | | | | | | > | | | | | | > > > > > > | 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 |
}
ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc == NULL) {
/*
* We're transferring to narrow seeks at this point; this is a bit complex
* because we have to check whether the seek is possible first (i.e.
* whether we are losing information in truncating the bits of the
* offset). Luckily, there's a defined error for what happens when trying
* to go out of the representable range.
*/
#ifndef TCL_NO_DEPRECATED
if (offset<LONG_MIN || offset>LONG_MAX) {
*errorCodePtr = EOVERFLOW;
return -1;
}
return parentSeekProc(parentData, offset,
mode, errorCodePtr);
#else
*errorCodePtr = EINVAL;
return -1;
#endif
}
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformSetOptionProc --
*
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
static int
TransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
| | | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 |
static int
TransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverSetOptionProc *setOptionProc;
setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
if (setOptionProc == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 |
static int
TransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
| | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
static int
TransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
return getOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, dsPtr);
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | * * Result: * None. * *---------------------------------------------------------------------- */ | < | | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
*
* Result:
* None.
*
*----------------------------------------------------------------------
*/
static void
TransformWatchProc(
ClientData instanceData, /* Channel to watch. */
int mask) /* Events of interest. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan;
/*
* The caller expressed interest in events occuring for this channel. We
* are forwarding the call to the underlying channel now.
*/
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
static int
TransformGetFileHandleProc(
ClientData instanceData, /* Channel to query. */
int direction, /* Direction of interest. */
ClientData *handlePtr) /* Place to store the handle into. */
{
| | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
static int
TransformGetFileHandleProc(
ClientData instanceData, /* Channel to query. */
int direction, /* Direction of interest. */
ClientData *handlePtr) /* Place to store the handle into. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
/*
* Return the handle belonging to parent channel. IOW, pass the request
* down and the result up.
*/
return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
static int
TransformNotifyProc(
ClientData clientData, /* The state of the notified
* transformation. */
int mask) /* The mask of occuring events. */
{
| | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 |
static int
TransformNotifyProc(
ClientData clientData, /* The state of the notified
* transformation. */
int mask) /* The mask of occuring events. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
/*
* An event occured in the underlying channel. This transformation doesn't
* process such events thus returns the incoming mask unchanged.
*/
if (dataPtr->timer != NULL) {
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
*----------------------------------------------------------------------
*/
static void
TransformChannelHandlerTimer(
ClientData clientData) /* Transformation to query. */
{
| | | 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 |
*----------------------------------------------------------------------
*/
static void
TransformChannelHandlerTimer(
ClientData clientData) /* Transformation to query. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
dataPtr->timer = NULL;
if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) {
/*
* The timer fired, but either is there no (more) interest in the
* events it generates or nothing is available for reading, so ignore
* it and don't recreate it.
|
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
r->buf = (unsigned char *)ckalloc(r->allocated);
} else {
r->allocated += toWrite + INCREMENT;
r->buf = (unsigned char *)ckrealloc(r->buf, r->allocated);
}
}
/*
* Now we may copy the data.
*/
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIORChan.c -- * * This file contains the implementation of Tcl's generic channel * reflection code, which allows the implementation of Tcl channels in * Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #219 for the specification of this functionality. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIORChan.c -- * * This file contains the implementation of Tcl's generic channel * reflection code, which allows the implementation of Tcl channels in * Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #219 for the specification of this functionality. * * Copyright © 2004-2005 ActiveState, a divison of Sophos * * 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" |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | #endif /* * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, | | > > | > > > > | | | 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 |
#endif
/*
* Signatures of all functions used in the C layer of the reflection.
*/
static int ReflectClose(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
static int ReflectOutput(ClientData clientData, const char *buf,
int toWrite, int *errorCodePtr);
static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
#if TCL_THREADS
static void ReflectThread(ClientData clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
#endif
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static void TimerRunRead(ClientData clientData);
static void TimerRunWrite(ClientData clientData);
/*
* The C layer channel type/driver definition used by the reflection. This is
* a version 3 structure.
*/
static const Tcl_ChannelType tclRChannelType = {
"tclrchannel", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close channel, clean instance data */
ReflectInput, /* Handle read request */
ReflectOutput, /* Handle write request */
#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. NULL'able */
#else
NULL,
#endif
ReflectSetOption, /* Set options. NULL'able */
ReflectGetOption, /* Get options. NULL'able */
ReflectWatch, /* Initialize notifier */
NULL, /* Get OS handle from the channel. NULL'able */
ReflectClose, /* No close2 support. NULL'able */
ReflectBlock, /* Set blocking/nonblocking. NULL'able */
NULL, /* Flush channel. Not used by core. NULL'able */
NULL, /* Handle events. NULL'able */
ReflectSeekWide, /* Move access point (64 bit). NULL'able */
#if TCL_THREADS
ReflectThread, /* thread action, tracking owner */
#else
NULL, /* thread action */
#endif
NULL /* truncate */
};
/*
* Instance data for a reflected channel. ===========================
*/
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 | (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedChannelMap * GetThreadReflectedChannelMap(void); | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedChannelMap * GetThreadReflectedChannelMap(void); static Tcl_ExitProc DeleteThreadReflectedChannelMap; #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) static Tcl_Obj * MarshallError(Tcl_Interp *interp); |
| ︙ | ︙ | |||
442 443 444 445 446 447 448 | static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); | | < | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); static Tcl_InterpDeleteProc DeleteReflectedChannelMap; static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); static void MarkDead(ReflectedChannel *rcPtr); /* * Global constant strings (messages). ================== * These string are used directly as bypass errors, thus they have to be valid * Tcl lists where the last element is the message itself. Hence the |
| ︙ | ︙ | |||
488 489 490 491 492 493 494 | * Creates a new channel. * *---------------------------------------------------------------------- */ int TclChanCreateObjCmd( | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
* Creates a new channel.
*
*----------------------------------------------------------------------
*/
int
TclChanCreateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
ReflectedChannel *rcPtr; /* Instance data of the new channel */
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 |
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.
*/
| | > > | 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 |
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 *)ckalloc(sizeof(Tcl_ChannelType));
memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
if (!(methods & FLAG(METH_CONFIGURE))) {
clonePtr->setOptionProc = NULL;
}
if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
clonePtr->getOptionProc = NULL;
}
if (!(methods & FLAG(METH_BLOCKING))) {
clonePtr->blockModeProc = NULL;
}
if (!(methods & FLAG(METH_SEEK))) {
#ifndef TCL_NO_DEPRECATED
clonePtr->seekProc = NULL;
#endif
clonePtr->wideSeekProc = NULL;
}
chanPtr->typePtr = clonePtr;
}
/*
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
ReflectEventRun(
Tcl_Event *ev,
| | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
ReflectEventRun(
Tcl_Event *ev,
TCL_UNUSED(int) /*flags*/)
{
/* OWNER thread
*
* Note: When the channel is closed any pending events of this type are
* deleted. See ReflectClose() for the Tcl_DeleteEvents() calls
* accomplishing that.
*/
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
}
return 1;
}
#endif
int
TclChanPostEventObjCmd(
| | | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 |
}
return 1;
}
#endif
int
TclChanPostEventObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
/*
* Ensure -> HANDLER thread
*
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
* defined in this interpreter.
*
* We keep the old checks for both, for paranioa, but abort now instead of
* throwing errors, as failure now means that our internal datastructures
* have gone seriously haywire.
*/
| | | | 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 |
* defined in this interpreter.
*
* We keep the old checks for both, for paranioa, but abort now instead of
* throwing errors, as failure now means that our internal datastructures
* have gone seriously haywire.
*/
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
chanTypePtr = Tcl_GetChannelType(chan);
/*
* We use a function referenced by the channel type as our cookie to
* detect calls to non-reflecting channels. The channel type itself is not
* suitable, as it might not be the static definition in this file, but a
* clone thereof. And while we have reserved the name of the type nothing
* in the core checks against violation, so someone else might have
* created a channel type using our name, clashing with ourselves.
*/
if (chanTypePtr->watchProc != &ReflectWatch) {
Tcl_Panic("TclChanPostEventObjCmd: channel is not a reflected channel");
}
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter");
}
/*
* Second argument is a list of events. Allowed entries are "read",
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
/*
* We are not preserving the structure here. When the channel is
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
| | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 |
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->readTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}
static void
TimerRunWrite(
ClientData clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->writeTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}
/*
* Channel error message marshalling utilities.
*/
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
| | > | > > > > | 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 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
Tcl_Interp *interp,
int flags)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
int result; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp */
Tcl_HashEntry *hPtr; /* Entry in the above map */
const Tcl_ChannelType *tctPtr;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
* interpreters, and therefore we cannot call upon the handler command
* anymore. Threading is irrelevant as well. We simply clean up all
* our C level data structures and leave the Tcl level to the other
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *toReadObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
Tcl_Obj *resObj; /* Result data for 'read' */
/*
* Are we in the correct thread?
|
| ︙ | ︙ | |||
1327 1328 1329 1330 1331 1332 1333 |
p.input.toRead = toRead;
ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
/*
| | | | | 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 |
p.input.toRead = toRead;
ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
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.input.toRead = -1;
} else {
*errorCodePtr = EOK;
}
return p.input.toRead;
}
#endif
/* ASSERT: rcPtr->method & FLAG(METH_READ) */
/* ASSERT: rcPtr->mode & TCL_READABLE */
Tcl_Preserve(rcPtr);
TclNewIntObj(toReadObj, toRead);
Tcl_IncrRefCount(toReadObj);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
*errorCodePtr = -code;
|
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | | | 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 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *bufObj;
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.output.buf = buf;
p.output.toWrite = toWrite;
ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p);
if (p.base.code != TCL_OK) {
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;
|
| ︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
| | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *offObj, *baseObj;
Tcl_Obj *resObj; /* Result for 'seek' */
Tcl_WideInt newLoc;
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 |
}
#endif
/* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
Tcl_Preserve(rcPtr);
| | | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
}
#endif
/* 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) {
|
| ︙ | ︙ | |||
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 |
return newLoc;
invalid:
*errorCodePtr = EINVAL;
newLoc = -1;
goto stop;
}
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
| > > | 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 |
return newLoc;
invalid:
*errorCodePtr = EINVAL;
newLoc = -1;
goto stop;
}
#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
|
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
| | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *maskObj;
/*
* We restrict the interest to what the channel can support. IOW there
* will never be write events for a channel which is not writable.
* Analoguously for read events and non-readable channels.
*/
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
| | | 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *blockObj;
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result data for 'blocking' */
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1789 1790 1791 1792 1793 1794 1795 |
*/
static void
ReflectThread(
ClientData clientData,
int action)
{
| | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 |
*/
static void
ReflectThread(
ClientData 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;
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 |
static int
ReflectSetOption(
ClientData 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 */
{
| | | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
static int
ReflectSetOption(
ClientData 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 */
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj, *valueObj;
int result; /* Result code for 'configure' */
Tcl_Obj *resObj; /* Result data for 'configure' */
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 |
Tcl_DString *dsPtr) /* String to place the result into */
{
/*
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
| | | | 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 |
Tcl_DString *dsPtr) /* String to place the result into */
{
/*
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
int listc, result = TCL_OK;
Tcl_Obj **listv;
MethodName method;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardedOperation opcode;
ForwardParam p;
p.getOpt.name = optionName;
p.getOpt.value = dsPtr;
if (optionName == NULL) {
opcode = ForwardedGetOptAll;
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
NewReflectedChannel(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
| | | | | 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 |
NewReflectedChannel(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
rcPtr->readTimer = 0;
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
Tcl_NewStringObj(methodNames[mn++], -1));
}
Tcl_IncrRefCount(rcPtr->methods);
rcPtr->name = handleObj;
Tcl_IncrRefCount(rcPtr->name);
return rcPtr;
|
| ︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 |
*----------------------------------------------------------------------
*/
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
| | | | < | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
*----------------------------------------------------------------------
*/
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL);
if (rcmPtr == NULL) {
rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr);
}
return rcmPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2550 2551 2552 2553 2554 2555 2556 |
}
static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
| | | 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 |
}
static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData;
/* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
#if TCL_THREADS
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 |
* DeleteThreadReflectedChannelMap(), just restricted to the channels of
* this interp.
*/
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
| | | | 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 |
* DeleteThreadReflectedChannelMap(), just restricted to the channels of
* this interp.
*/
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
ckfree(&rcmPtr->map);
|
| ︙ | ︙ | |||
2623 2624 2625 2626 2627 2628 2629 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
| | | | 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
* 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]
*/
if (evPtr == NULL) {
continue;
}
paramPtr = evPtr->param;
if (!evPtr) {
continue;
|
| ︙ | ︙ | |||
2655 2656 2657 2658 2659 2660 2661 |
* interpreter. They have already been marked as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | | 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 |
* interpreter. They have already been marked as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
/*
* Ignore entries for other interpreters.
*/
continue;
|
| ︙ | ︙ | |||
2696 2697 2698 2699 2700 2701 2702 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
| | | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
tsdPtr->rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
}
return tsdPtr->rcmPtr;
}
|
| ︙ | ︙ | |||
2724 2725 2726 2727 2728 2729 2730 | * Deletes the hash table of channels. * *---------------------------------------------------------------------- */ static void DeleteThreadReflectedChannelMap( | | | 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 |
* Deletes the hash table of channels.
*
*----------------------------------------------------------------------
*/
static void
DeleteThreadReflectedChannelMap(
TCL_UNUSED(ClientData))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2773 2774 2775 2776 2777 2778 2779 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
| | | | 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 |
* 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]
*/
if (evPtr == NULL ) {
continue;
}
paramPtr = evPtr->param;
if (!evPtr) {
continue;
|
| ︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 |
* through the channels, remove all, mark them as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
| | | | 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
* through the channels, remove all, mark them as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
Tcl_Channel chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rcmPtr);
}
|
| ︙ | ︙ | |||
2859 2860 2861 2862 2863 2864 2865 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent));
resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rcPtr = rcPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2948 2949 2950 2951 2952 2953 2954 |
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
| | | 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 |
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
* The receiver part for the operations coming from the OWNER thread.
* See ForwardOpToHandlerThread() for the transmitter.
*
|
| ︙ | ︙ | |||
3030 3031 3032 3033 3034 3035 3036 |
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
MarkDead(rcPtr);
break;
}
case ForwardedInput: {
| | > > | | | 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 |
Tcl_GetChannelName(rcPtr->chan));
Tcl_DeleteHashEntry(hPtr);
MarkDead(rcPtr);
break;
}
case ForwardedInput: {
Tcl_Obj *toReadObj;
TclNewIntObj(toReadObj, paramPtr->input.toRead);
Tcl_IncrRefCount(toReadObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
|
| ︙ | ︙ | |||
3108 3109 3110 3111 3112 3113 3114 |
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedSeek: {
| | | > > > | | | | | | 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 |
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedSeek: {
Tcl_Obj *offObj;
Tcl_Obj *baseObj;
TclNewIntObj(offObj, paramPtr->seek.offset);
baseObj = Tcl_NewStringObj(
(paramPtr->seek.seekMode==SEEK_SET) ? "start" :
(paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){
ForwardSetObjError(paramPtr, resObj);
paramPtr->seek.offset = -1;
} else {
/*
* Process a regular result. If the type is wrong this may change
* into an error.
|
| ︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
| | | 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
char *buf = (char *)ckalloc(200);
sprintf(buf,
"{Expected list with even number of elements, got %d %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
|
| ︙ | ︙ | |||
3294 3295 3296 3297 3298 3299 3300 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
| | | 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
ForwardParam *paramPtr;
/*
* NOTE (2): Can this handler be called with the originator blocked?
*/
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIORTrans.c -- * * This file contains the implementation of Tcl's generic transformation * reflection code, which allows the implementation of Tcl channel * transformations in Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #230 for the specification of this functionality. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIORTrans.c -- * * This file contains the implementation of Tcl's generic transformation * reflection code, which allows the implementation of Tcl channel * transformations in Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #230 for the specification of this functionality. * * Copyright © 2007-2008 ActiveState. * * 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" |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | #endif /* * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, | | > > | > > > > | | 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 |
#endif
/*
* Signatures of all functions used in the C layer of the reflection.
*/
static int ReflectClose(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
static int ReflectOutput(ClientData clientData, const char *buf,
int toWrite, int *errorCodePtr);
static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static int ReflectHandle(ClientData clientData, int direction,
ClientData *handle);
static int ReflectNotify(ClientData clientData, int mask);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType tclRTransformType = {
"tclrtransform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel. */
TCL_CLOSE2PROC, /* Close channel, clean instance data. */
ReflectInput, /* Handle read request. */
ReflectOutput, /* Handle write request. */
#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. */
#else
NULL, /* Move location of access point. */
#endif
ReflectSetOption, /* Set options. */
ReflectGetOption, /* Get options. */
ReflectWatch, /* Initialize notifier. */
ReflectHandle, /* Get OS handle from the channel. */
ReflectClose, /* No close2 support. NULL'able. */
ReflectBlock, /* Set blocking/nonblocking. */
NULL, /* Flush channel. Not used by core.
* NULL'able. */
ReflectNotify, /* Handle events. */
ReflectSeekWide, /* Move access point (64 bit). */
NULL, /* thread action */
NULL /* truncate */
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 | * Creates a new channel. * *---------------------------------------------------------------------- */ int TclChanPushObjCmd( | | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
* Creates a new channel.
*
*----------------------------------------------------------------------
*/
int
TclChanPushObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
ReflectedTransform *rtPtr; /* Instance data of the new (transform)
* channel. */
Tcl_Obj *chanObj; /* Handle of parent channel */
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 | * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ int TclChanPopObjCmd( | | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
* latter implies that arbitrary side effects are possible.
*
*----------------------------------------------------------------------
*/
int
TclChanPopObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
/*
* Syntax: chan pop CHANNEL
* [0] [1] [2]
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
| | > | > > > > | 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 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
Tcl_Interp *interp,
int flags)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int errorCode, errorCodeSet = 0;
int result = TCL_OK; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
* interpreters, and therefore we cannot call upon the handler command
* anymore. Threading is irrelevant as well. We simply clean up all
* our C level data structures and leave the Tcl level to the other
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int gotBytes, copied, readBytes;
Tcl_Obj *bufObj;
/*
* The following check can be done before thread redirection, because we
* are reading from an item which is readonly, i.e. will never change
* during the lifetime of the channel.
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
Tcl_SetByteArrayLength(bufObj, readBytes);
if (!TransformRead(rtPtr, errorCodePtr, bufObj)) {
goto error;
}
if (Tcl_IsShared(bufObj)) {
Tcl_DecrRefCount(bufObj);
| | | 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
Tcl_SetByteArrayLength(bufObj, readBytes);
if (!TransformRead(rtPtr, errorCodePtr, bufObj)) {
goto error;
}
if (Tcl_IsShared(bufObj)) {
Tcl_DecrRefCount(bufObj);
TclNewObj(bufObj);
Tcl_IncrRefCount(bufObj);
}
Tcl_SetByteArrayLength(bufObj, 0);
} /* while toRead > 0 */
stop:
if (gotBytes == 0) {
|
| ︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* The following check can be done before thread redirection, because we
* are reading from an item which is readonly, i.e. will never change
* during the lifetime of the channel.
*/
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
| | < < < < < < < < < < < < | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
Channel *parent = (Channel *) rtPtr->parent;
Tcl_WideInt curPos; /* Position on the device. */
/*
* Check if we can leave out involving the Tcl level, i.e. transformation
* handler. This is true for tell requests, and transformations which
* support neither flush, nor drain. For these cases we can pass the
* request down and the result back up unchanged.
*/
|
| ︙ | ︙ | |||
1378 1379 1380 1381 1382 1383 1384 |
/*
* Now seek to the new position in the channel as requested by the
* caller. Note that we prefer the wideSeekProc if that is available and
* non-NULL...
*/
| | | < | | | | | | | > > > > > > > > > > | 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 |
/*
* Now seek to the new position in the channel as requested by the
* caller. Note that we prefer the wideSeekProc if that is available and
* non-NULL...
*/
if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
#ifndef TCL_NO_DEPRECATED
if (offset < LONG_MIN || offset > LONG_MAX) {
*errorCodePtr = EOVERFLOW;
curPos = -1;
} else {
curPos = Tcl_ChannelSeekProc(parent->typePtr)(
parent->instanceData, offset, seekMode,
errorCodePtr);
}
#else
*errorCodePtr = EINVAL;
curPos = -1;
#endif
} else {
curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
seekMode, errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
}
*errorCodePtr = EOK;
Tcl_Release(rtPtr);
return curPos;
}
#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
|
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
| | | 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
Tcl_DriverWatchProc *watchProc;
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(rtPtr->parent));
watchProc(Tcl_GetChannelInstanceData(rtPtr->parent), mask);
/*
* Management of the internal timer.
|
| ︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
| | | 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations simply record the blocking mode in their C level
* structure for use by --> ReflectInput. The Tcl level doesn't see this
* information or change. As such thread forwarding is not required.
*/
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
static int
ReflectSetOption(
ClientData 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 */
{
| | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 |
static int
ReflectSetOption(
ClientData 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;
/*
* Transformations have no options. Thus the call is passed down unchanged
* to the parent channel for processing. Its results are passed back
* unchanged as well. This all happens in the thread we are in. As the Tcl
* level is not involved there is no need for thread forwarding.
*/
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 |
static int
ReflectGetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
| | | 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 |
static int
ReflectGetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no options. Thus the call is passed down unchanged
* to the parent channel for processing. Its results are passed back
* unchanged as well. This all happens in the thread we are in. As the Tcl
* level is not involved there is no need for thread forwarding.
*
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 |
static int
ReflectHandle(
ClientData clientData,
int direction,
ClientData *handlePtr)
{
| | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
static int
ReflectHandle(
ClientData clientData,
int direction,
ClientData *handlePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no handle of their own. As such we simply query
* the parent channel for it. This way the qery will ripple down through
* all transformations until reaches the base channel. Which then returns
* its handle, or fails. The former will then ripple up the stack.
*
|
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 |
*/
static int
ReflectNotify(
ClientData clientData,
int mask)
{
| | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
*/
static int
ReflectNotify(
ClientData clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* An event occured in the underlying channel.
*
* We delete our timer. It was not fired, yet we are here, so the channel
* below generated such an event and we don't have to. The renewal of the
* interest after the execution of channel handlers will eventually cause
|
| ︙ | ︙ | |||
1741 1742 1743 1744 1745 1746 1747 |
*----------------------------------------------------------------------
*/
static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
| | | | 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
*----------------------------------------------------------------------
*/
static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
int listc;
Tcl_Obj **listv;
int i;
rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform));
/* rtPtr->chan: Assigned by caller. Dummy data here. */
/* rtPtr->methods: Assigned by caller. Dummy data here. */
rtPtr->chan = NULL;
rtPtr->methods = 0;
#if TCL_THREADS
|
| ︙ | ︙ | |||
1797 1798 1799 1800 1801 1802 1803 |
*
* listv [0] [listc-1] | [listc] [listc+1] |
* argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
* cmd ... pfx | method chan | detail1 detail2
*/
rtPtr->argc = listc + 2;
| | | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 |
*
* listv [0] [listc-1] | [listc] [listc+1] |
* argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
* cmd ... pfx | method chan | detail1 detail2
*/
rtPtr->argc = listc + 2;
rtPtr->argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (listc+4));
/*
* Duplicate object references.
*/
for (i=0; i<listc ; i++) {
Tcl_Obj *word = rtPtr->argv[i] = listv[i];
|
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
| | | | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL);
if (rtmPtr == NULL) {
rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RTMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
}
return rtmPtr;
}
|
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 |
* systems point of view and will not get closed. Therefore mark all as
* dead so that any future access will cause a proper error. For channels
* in a different thread we actually do the same as
* DeleteThreadReflectedTransformMap(), just restricted to the channels of
* this interp.
*/
| | | | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 |
* systems point of view and will not get closed. Therefore mark all as
* dead so that any future access will cause a proper error. For channels
* in a different thread we actually do the same as
* DeleteThreadReflectedTransformMap(), just restricted to the channels of
* this interp.
*/
rtmPtr = (ReflectedTransformMap *)clientData;
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rtmPtr->map);
ckfree(&rtmPtr->map);
|
| ︙ | ︙ | |||
2188 2189 2190 2191 2192 2193 2194 |
* interpreter. They have already been marked as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 |
* interpreter. They have already been marked as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
if (rtPtr->interp != interp) {
/*
* Ignore entries for other interpreters.
*/
continue;
|
| ︙ | ︙ | |||
2268 2269 2270 2271 2272 2273 2274 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
| | | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
tsdPtr->rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
}
return tsdPtr->rtmPtr;
}
|
| ︙ | ︙ | |||
2296 2297 2298 2299 2300 2301 2302 | * Deletes the hash table of channels. * *---------------------------------------------------------------------- */ static void DeleteThreadReflectedTransformMap( | | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 |
* Deletes the hash table of channels.
*
*----------------------------------------------------------------------
*/
static void
DeleteThreadReflectedTransformMap(
TCL_UNUSED(ClientData))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedTransformMap *rtmPtr; /* The map */
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 |
* through the channels, remove all, mark them as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
| | | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 |
* through the channels, remove all, mark them as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
ReflectedTransform *rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
FreeReflectedTransformArgs(rtPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rtmPtr);
|
| ︙ | ︙ | |||
2403 2404 2405 2406 2407 2408 2409 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent));
resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rtPtr = rtPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
| | | 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 |
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
TCL_UNUSED(int) /*mask*/)
{
/*
* 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,
|
| ︙ | ︙ | |||
2597 2598 2599 2600 2601 2602 2603 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
| | | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
Tcl_DecrRefCount(bufObj);
|
| ︙ | ︙ | |||
2631 2632 2633 2634 2635 2636 2637 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
| | | 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
Tcl_DecrRefCount(bufObj);
|
| ︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 |
unsigned char *bytev; /* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
| | | 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 |
unsigned char *bytev; /* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
| | | 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 |
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
|
| ︙ | ︙ | |||
2747 2748 2749 2750 2751 2752 2753 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
| | | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
ForwardParam *paramPtr;
/*
* NOTE (2): Can this handler be called with the originator blocked?
*/
|
| ︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 |
*----------------------------------------------------------------------
*/
static void
TimerRun(
ClientData clientData)
{
| | | 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 |
*----------------------------------------------------------------------
*/
static void
TimerRun(
ClientData clientData)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
rtPtr->timer = NULL;
Tcl_NotifyChannel(rtPtr->chan, TCL_READABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
1 2 3 4 5 | /* * tclIOSock.c -- * * Common routines used by all socket based channel types. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * 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" |
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
1 2 3 4 5 6 7 8 9 | /* * tclIOUtil.c -- * * Provides an interface for managing filesystems in Tcl, and also for * creating a filesystem interface in Tcl arbitrary facilities. All * filesystem operations are performed via this interface. Vince Darley * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclIOUtil.c -- * * Provides an interface for managing filesystems in Tcl, and also for * creating a filesystem interface in Tcl arbitrary facilities. All * filesystem operations are performed via this interface. Vince Darley * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * 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 |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | static void FsRecacheFilesystemList(void); static void Claim(void); static void Disclaim(void); static void * DivertFindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void DivertUnloadFile(Tcl_LoadHandle loadHandle); | < | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | static void FsRecacheFilesystemList(void); static void Claim(void); static void Disclaim(void); static void * DivertFindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); static void DivertUnloadFile(Tcl_LoadHandle loadHandle); /* * Functions that provide native filesystem support. They are private and * should be used only here. They should be called instead of calling Tclp... * native filesystem functions. Others should use the Tcl_FS... functions * which ensure correct and complete virtual filesystem support. */ |
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
* The basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
| | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
* The basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/*
* Discard the cwd copy.
*/
if (tsdPtr->cwdPathPtr != NULL) {
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
/*
* Refill the cache, honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
| | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
/*
* Refill the cache, honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
tsdPtr->filesystemList = list;
|
| ︙ | ︙ | |||
849 850 851 852 853 854 855 |
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
| | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * whether the file exists, or even whether the pathname makes sense. * *---------------------------------------------------------------------- */ void Tcl_FSMountsChanged( | | < | < < | 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
* whether the file exists, or even whether the pathname makes sense.
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(
TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/)
/*
* fsPtr is currently unused. In the future it might invalidate files for
* a particular filesystem, or take some other more advanced action.
*/
{
/*
* Increment the filesystem epoch to invalidate every existing cached
* internal representation.
*/
Tcl_MutexLock(&filesystemMutex);
if (++theFilesystemEpoch == 0) {
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
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
| | | 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 |
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. */
{
int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
const char *string;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
* uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set the channel to that encoding.
| < | | > > | | | | | | < | | 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 |
* uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set the channel to that encoding.
* Otherwise use utf-8. If the encoding is unknown report an error.
*/
if (encodingName == NULL) {
encodingName = "utf-8";
}
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_Close(interp,chan);
return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
* Read first character of stream to check for utf-8 BOM
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
| | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
|
| ︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 |
int
TclNREvalFile(
Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
Tcl_Obj *pathPtr, /* Pathname of a file containing the script to
* evaluate. Tilde-substitution is performed on
* this pathname. */
const char *encodingName) /* The name of an encoding to use, or NULL to
| | | 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 |
int
TclNREvalFile(
Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
Tcl_Obj *pathPtr, /* Pathname of a file containing the script to
* evaluate. Tilde-substitution is performed on
* this pathname. */
const char *encodingName) /* The name of an encoding to use, or NULL to
* use the utf-8 encoding. */
{
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile, *objPtr;
Interp *iPtr;
Tcl_Channel chan;
const char *string;
|
| ︙ | ︙ | |||
1858 1859 1860 1861 1862 1863 1864 |
* uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set the channel to that encoding.
| < | | > > | | | | | | < | | 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 |
* uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set the channel to that encoding.
* Otherwise use utf-8. If the encoding is unknown report an error.
*/
if (encodingName == NULL) {
encodingName = "utf-8";
}
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_Close(interp, chan);
return TCL_ERROR;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
* Read first character of stream to check for utf-8 BOM
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
|
| ︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 |
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
| | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 |
static int
EvalFileCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 |
static int
EvalFileCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldScriptFile = (Tcl_Obj *)data[0];
Tcl_Obj *pathPtr = (Tcl_Obj *)data[1];
Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
* Restore the original iPtr->scriptFile value, but because the value may
* have hanged during evaluation, don't assume it currently points to
* pathPtr.
*/
|
| ︙ | ︙ | |||
2311 2312 2313 2314 2315 2316 2317 | * None. * *---------------------------------------------------------------------- */ static const char *const * NativeFileAttrStrings( | | | | 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 |
* None.
*
*----------------------------------------------------------------------
*/
static const char *const *
NativeFileAttrStrings(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj **))
{
return tclpFileAttrStrings;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2697 2698 2699 2700 2701 2702 2703 | * Threading issue: Multiple threads at system startup could in * principle call this function simultaneously. They will * therefore each set the cwdPathPtr independently, which is a * bit peculiar, but should be fine. Once we have a cwd, we'll * always be in the 'else' branch below which is simpler. */ | | | 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 |
* Threading issue: Multiple threads at system startup could in
* principle call this function simultaneously. They will
* therefore each set the cwdPathPtr independently, which is a
* bit peculiar, but should be fine. Once we have a cwd, we'll
* always be in the 'else' branch below which is simpler.
*/
void *cd = (void *) Tcl_FSGetNativePath(norm);
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/*
|
| ︙ | ︙ | |||
3015 3016 3017 3018 3019 3020 3021 |
* dynamic shared object. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **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
* object. Can be passed to
* (*unloadProcPtr)() to unload the file. */
| | < < | 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 |
* dynamic shared object. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **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
* object. Can be passed to
* (*unloadProcPtr)() to unload the file. */
TCL_UNUSED(Tcl_FSUnloadFileProc **))
{
const char *symbols[3];
void *procPtrs[2];
int res;
symbols[0] = sym1;
symbols[1] = sym2;
|
| ︙ | ︙ | |||
3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 |
*
* 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available).
*
*/
#ifdef hpux
return 1;
#else
char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
| > | > > | 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 |
*
* 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
char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
#ifndef TCL_TEMPLOAD_NO_UNLINK
(void)shlibFile;
#else
/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether
* this automatic overriding of unlink is included.
*/
#ifndef NO_FSTATFS
{
struct statfs fs;
/*
|
| ︙ | ︙ | |||
3172 3173 3174 3175 3176 3177 3178 |
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (fsPtr->loadFileProc != NULL) {
| | | 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 |
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (fsPtr->loadFileProc != NULL) {
retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc))
(interp, pathPtr, handlePtr, &unloadProcPtr, flags);
if (retVal == TCL_OK) {
if (*handlePtr == NULL) {
return TCL_ERROR;
}
if (interp) {
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 |
goto mustCopyToTempAnyway;
}
buffer = TclpLoadMemoryGetBuffer(interp, size);
if (!buffer) {
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
| | | 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 |
goto mustCopyToTempAnyway;
}
buffer = TclpLoadMemoryGetBuffer(interp, size);
if (!buffer) {
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
ret = Tcl_Read(data, (char *)buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
&unloadProcPtr, flags);
if (ret == TCL_OK && *handlePtr != NULL) {
goto resolveSymbols;
}
}
|
| ︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 |
return TCL_OK;
}
/*
* Divert the unloading in order to unload and cleanup the temporary file.
*/
| | | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 |
return TCL_OK;
}
/*
* Divert the unloading in order to unload and cleanup the temporary file.
*/
tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information in order to clean up the diverted
* load completely on platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
|
| ︙ | ︙ | |||
3397 3398 3399 3400 3401 3402 3403 |
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
| | | 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 |
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
divertedLoadHandle->clientData = tvdlPtr;
divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
*handlePtr = divertedLoadHandle;
if (interp) {
Tcl_ResetResult(interp);
|
| ︙ | ︙ | |||
3764 3765 3766 3767 3768 3769 3770 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSListVolumes(void)
{
FilesystemRecord *fsRecPtr;
| | > | 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSListVolumes(void)
{
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr;
/*
* Call each "listVolumes" function of each registered filesystem in
* succession. A non-NULL return value indicates the particular function
* has succeeded.
*/
TclNewObj(resultPtr);
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
|
| ︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 |
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
if (resultPtr == NULL) {
| | | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
if (resultPtr == NULL) {
TclNewObj(resultPtr);
}
fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr,
pattern, &mountsOnly);
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
|
| ︙ | ︙ | |||
3902 3903 3904 3905 3906 3907 3908 |
/*
* Add the drive name as first element of the result. The drive name may
* contain strange characters like colons and sequences of forward slashes
* For example, 'ftp://' is a valid drive name.
*/
| | | 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 |
/*
* Add the drive name as first element of the result. The drive name may
* contain strange characters like colons and sequences of forward slashes
* For example, 'ftp://' is a valid drive name.
*/
TclNewObj(result);
p = Tcl_GetString(pathPtr);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(p, driveNameLength));
p += driveNameLength;
/*
* Add the remaining pathname elements to the list.
|
| ︙ | ︙ | |||
4084 4085 4086 4087 4088 4089 4090 |
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
| | | 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 |
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;
}
if (driveNameLengthPtr != NULL) {
*driveNameLengthPtr = len;
}
|
| ︙ | ︙ | |||
4487 4488 4489 4490 4491 4492 4493 |
* Avoid possible segfaults or nondeterministic memory leaks where the
* reference count has been incorreclty managed.
*/
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
| | | 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 |
* Avoid possible segfaults or nondeterministic memory leaks where the
* reference count has been incorreclty managed.
*/
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
/* Start with an up-to-date copy of the filesystem. */
fsRecPtr = FsGetFirstFilesystem();
Claim();
/*
* Ensure that pathPtr is a valid pathname.
*/
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
|
| ︙ | ︙ | |||
4677 4678 4679 4680 4681 4682 4683 | * None. * *--------------------------------------------------------------------------- */ static Tcl_Obj * NativeFilesystemSeparator( | | | | 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 |
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
NativeFilesystemSeparator(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
1 2 3 4 5 6 7 | /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type is used * to lookup a keyword in a table of valid values and cache the index of * the matching entry. Also provides table-based argv/argc processing. * | | | | < | 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 | /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type is used * to lookup a keyword in a table of valid values and cache the index of * the matching entry. Also provides table-based argv/argc processing. * * Copyright © 1990-1994 The Regents of the University of California. * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 2006 Sam Bromley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * Prototypes for functions defined later in this file: */ static int GetIndexFromObjList(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr, const char *msg, int flags, int *indexPtr); static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); static int PrefixAllObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PrefixLongestObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
*/
static const Tcl_ObjType indexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
*/
static const Tcl_ObjType indexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* The definition of the internal representation of the "index" object; The
* internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
* value of objPtr; last entry must be NULL
* and there must not be duplicate entries. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
| | | | 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 |
* value of objPtr; last entry must be NULL
* and there must not be duplicate entries. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
if (!(flags & TCL_INDEX_TEMP_TABLE)) {
/*
* See if there is a valid cached result from a previous lookup (doing the
* check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
* the common case where the result is cached).
*/
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
* on odd platforms like a Cray PVP...
*/
if (indexRep->tablePtr == (void *) tablePtr
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
return result;
}
/*
* Build a string table from the list.
*/
| | | | 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 |
return result;
}
/*
* Build a string table from the list.
*/
tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *));
for (t = 0; t < objc; t++) {
if (objv[t] == objPtr) {
/*
* An exact match is always chosen, so we can stop here.
*/
ckfree(tablePtr);
*indexPtr = t;
return TCL_OK;
}
tablePtr[t] = Tcl_GetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr);
ckfree(tablePtr);
return result;
}
/*
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
| | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (!(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
}
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = (const char* const*)tablePtr, idx = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
index = idx;
goto done;
}
}
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
| | | | | | 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 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (!(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjIntRep ir;
indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
ir.twoPtrValue.ptr1 = indexRep;
Tcl_StoreIntRep(objPtr, &indexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
entryPtr = (const char* const *)tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
if (*entryPtr == NULL) {
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfIndex --
*
* This function is called to convert a Tcl object from index internal
* form to its string form. No abbreviation is ever generated.
*
* Results:
* None.
*
* Side effects:
* The string representation of the object is updated.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
IndexRep *indexRep = (IndexRep *)TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjIntRep ir;
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjIntRep ir;
IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1,
sizeof(IndexRep));
ir.twoPtrValue.ptr1 = dupIndexRep;
Tcl_StoreIntRep(dupPtr, &indexType, &ir);
}
|
| ︙ | ︙ | |||
570 571 572 573 574 575 576 | * None. * *---------------------------------------------------------------------- */ static int PrefixMatchObjCmd( | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixMatchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags = 0, result, index;
int dummyLength, i, errorLength;
Tcl_Obj *errorPtr = NULL;
const char *message = "option";
Tcl_Obj *tablePtr, *objPtr, *resultPtr;
static const char *const matchOptions[] = {
"-error", "-exact", "-message", NULL
};
enum matchOptionsEnum {
PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE
};
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? table string");
return TCL_ERROR;
}
for (i = 1; i < (objc - 2); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum matchOptionsEnum) index) {
case PRFMATCH_EXACT:
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
}
if (Tcl_IsShared(errorPtr)) {
errorPtr = Tcl_DuplicateObj(errorPtr);
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
| | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
}
if (Tcl_IsShared(errorPtr)) {
errorPtr = Tcl_DuplicateObj(errorPtr);
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result));
return Tcl_SetReturnOptions(interp, errorPtr);
}
result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
694 695 696 697 698 699 700 | * None. * *---------------------------------------------------------------------- */ static int PrefixAllObjCmd( | | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixAllObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int tableObjc, result, t, length, elemLength;
const char *string, *elemString;
Tcl_Obj **tableObjv, *resultPtr;
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * None. * *---------------------------------------------------------------------- */ static int PrefixLongestObjCmd( | | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixLongestObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int tableObjc, result, i, t, length, elemLength, resultLength;
const char *string, *elemString, *resultString;
Tcl_Obj **tableObjv;
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
| | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
resultLength = TclUtfPrev(&resultString[i+1],
resultString) - resultString;
break;
}
}
}
}
if (resultLength > 0) {
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
| | | | 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 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
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 (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 |
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(objv[i], &indexType))) {
| | | | 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 |
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(objv[i], &indexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 | * 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] */ nrem = 1; | | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
* 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]
*/
nrem = 1;
leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
leftovers[0] = objv[0];
} else {
nrem = 0;
leftovers = NULL;
}
/*
|
| ︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
| | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
*remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
return TCL_OK;
/*
* Make sure to handle freeing any temporary space we've allocated on the
* way to an error.
*/
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
1 2 3 4 5 6 7 | # tclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file # is used to generate the tclIntDecls.h, tclIntPlatDecls.h # and tclStubInit.c files # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # tclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file # is used to generate the tclIntDecls.h, tclIntPlatDecls.h # and tclStubInit.c files # # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 2001 Kevin B. Kenny. All rights reserved. # Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. library tcl # Define the unsupported generic interfaces. |
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
| | | | 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 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
void *TclpAlloc(unsigned int size)
}
#declare 70 {
# int TclpCopyFile(const char *source, const char *dest)
#}
#declare 71 {
# int TclpCopyDirectory(const char *source, const char *dest,
# Tcl_DString *errorPtr)
#}
#declare 72 {
# int TclpCreateDirectory(const char *path)
#}
#declare 73 {
# int TclpDeleteFile(const char *path)
#}
declare 74 {
void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
}
declare 76 {
unsigned long TclpGetSeconds(void)
}
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
declare 81 {
| | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
declare 81 {
void *TclpRealloc(void *ptr, unsigned int size)
}
#declare 82 {
# int TclpRemoveDirectory(const char *path, int recursive,
# Tcl_DString *errorPtr)
#}
#declare 83 {
# int TclpRenameFile(const char *source, const char *dest)
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
# core and NRE-enabled
# declare 228 {
| | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
# core and NRE-enabled
# declare 228 {
# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
# int skip, ProcErrorProc *errorProc)
# }
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
}
declare 230 {
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
declare 249 {
char *TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr)
}
# TIP #285: Script cancellation support.
declare 250 {
| | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
declare 249 {
char *TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr)
}
# TIP #285: Script cancellation support.
declare 250 {
void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
const char *bytes, int length, int flags)
}
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
declare 259 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
| > > > > > | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
declare 259 {
unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *lengthPtr)
}
declare 260 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
| < | < < > > | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
declare 5 unix {
int TclUnixWaitForFile_(int fd, int mask, int timeout)
}
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
|
| ︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 |
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
# Mac OS X specific functions
| | | | | | > > > < < | 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 |
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
# Mac OS X specific functions
declare 15 {unix macosx} {
int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
declare 16 {unix macosx} {
int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj *attributePtr)
}
declare 17 {unix macosx} {
int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr)
}
declare 18 {unix macosx} {
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 {unix macosx} {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
declare 22 {unix macosx} {
TclFile TclpCreateTempFile_(const char *contents)
}
declare 29 {win unix} {
int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h. | > > > > > > > > > > > | 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 | # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif #if defined(__cplusplus) # define TCL_UNUSED(T) T #elif defined(__GNUC__) && (__GNUC__ > 2) # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused)) #else # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h. |
| ︙ | ︙ | |||
910 911 912 913 914 915 916 917 918 919 920 921 922 923 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ struct Command; | > > > > > > | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 | /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily in * tclProc.c, tclCompile.c, and tclExecute.c. *---------------------------------------------------------------- */ #if defined(__GNUC__) && (__GNUC__ > 2) # define TCLFLEXARRAY 0 #else # define TCLFLEXARRAY 1 #endif /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. */ struct Command; |
| ︙ | ︙ | |||
953 954 955 956 957 958 959 |
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. */
| | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
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. */
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;
/*
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 |
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
int num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
| | | 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 |
*/
#define CLL_END (-1)
typedef struct ContLineLoc {
int num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
int 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. */
} ContLineLoc;
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
typedef struct ExecStack {
struct ExecStack *prevPtr;
struct ExecStack *nextPtr;
Tcl_Obj **markerPtr;
Tcl_Obj **endPtr;
Tcl_Obj **tosPtr;
| | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
typedef struct ExecStack {
struct ExecStack *prevPtr;
struct ExecStack *nextPtr;
Tcl_Obj **markerPtr;
Tcl_Obj **endPtr;
Tcl_Obj **tosPtr;
Tcl_Obj *stackWords[TCLFLEXARRAY];
} ExecStack;
/*
* 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
|
| ︙ | ︙ | |||
1692 1693 1694 1695 1696 1697 1698 |
* command. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
} Command;
/*
* Flag bits for commands.
*
| | | | | | > | 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 |
* command. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
} Command;
/*
* Flag bits for commands.
*
* CMD_DYING - If 1 the command is in the process of
* being deleted (its deleteProc is currently
* executing). Other attempts to delete the
* command should be ignored.
* CMD_TRACE_ACTIVE - If 1 the trace processing is currently
* underway for a rename/delete change. See the
* two flags below for which is currently being
* processed.
* CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
* CMD_COMPILES_EXPANDED - If 1 this command has a compiler that
* can handle expansion (provided it is not the
* first word).
* 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.
*----------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 |
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
| | | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
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. */
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
|
| ︙ | ︙ | |||
2131 2132 2133 2134 2135 2136 2137 |
/*
* The thread-specific data ekeko: cache pointers or values that
* (a) do not change during the thread's lifetime
* (b) require access to TSD to determine at runtime
* (c) are accessed very often (e.g., at each command call)
*
* Note that these are the same for all interps in the same thread. They
| | | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 |
/*
* The thread-specific data ekeko: cache pointers or values that
* (a) do not change during the thread's lifetime
* (b) require access to TSD to determine at runtime
* (c) are accessed very often (e.g., at each command call)
*
* 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;
void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
|
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 |
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &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) \
| | | < | | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 |
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &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) \
((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
&& ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \
? ((*(idxPtr) = (int)(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,
|
| ︙ | ︙ | |||
2590 2591 2592 2593 2594 2595 2596 |
Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;
| < < < < < < < < < | 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 |
Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
} TclFileAttrProcs;
/*
* Opaque handle used in pipeline routines to encapsulate platform-dependent
* state.
*/
typedef struct TclFile_ *TclFile;
|
| ︙ | ︙ | |||
2655 2656 2657 2658 2659 2660 2661 | typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); /* * 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 | | | | | | | | | | 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 |
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
* 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 {
unsigned int epoch; /* Epoch counter to detect changes in the
* global value. */
unsigned int 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;
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 | #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. */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ | > > | 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 | #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 */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
3065 3066 3067 3068 3069 3070 3071 | MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); | < | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 | MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, |
| ︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 | MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); | | | | 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 | MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(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 TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, |
| ︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 | MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); 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(ClientData 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 | > > > > > > > > > > > > > > > | 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 |
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
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);
#if TCL_UTF_MAX > 3
# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
# define TclUCS4Prev(src, ptr) (((src) > (ptr)) ? ((src) - 1) : (src))
# define TclUCS4Complete Tcl_UtfCharComplete
# define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 3) : Tcl_UtfCharComplete((src), (length)))
#else
MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
MODULE_SCOPE const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *, const Tcl_UniChar *);
# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 4) : Tcl_UtfCharComplete((src), (length)))
# define TclChar16Complete Tcl_UtfCharComplete
#endif
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData 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
|
| ︙ | ︙ | |||
3277 3278 3279 3280 3281 3282 3283 | # endif #endif MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); | | | > > > > > > > > > > | 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 | # endif #endif MODULE_SCOPE Tcl_WideInt 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, int length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); /* * 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: *---------------------------------------------------------------- */ MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
4058 4059 4060 4061 4062 4063 4064 | /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); | | | | 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 | /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, int start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, int first, int count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); |
| ︙ | ︙ | |||
4136 4137 4138 4139 4140 4141 4142 | /* * Just for the purposes of command-type registration. */ MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; | | | 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 | /* * Just for the purposes of command-type registration. */ MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; /* * TIP #462. |
| ︙ | ︙ | |||
4328 4329 4330 4331 4332 4333 4334 |
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *)(interp))->allocCache), \
(cachePtr->numObjects == 0))) { \
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
| | | 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 |
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *)(interp))->allocCache), \
(cachePtr->numObjects == 0))) { \
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
cachePtr->firstObjPtr = (Tcl_Obj *)(objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
AllocCache *cachePtr; \
|
| ︙ | ︙ | |||
4482 4483 4484 4485 4486 4487 4488 | * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ #define TclInvalidateStringRep(objPtr) \ | > > | | | | | > > | > > > > > > > > > > > > > > | > | | | | 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 |
* 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) { \
ckfree((char *)_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.
*/
#ifdef __cplusplus
extern "C" {
#endif
MODULE_SCOPE const char *const tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to test whether an object has a
* string representation (or is a 'pure' internal value).
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclHasStringRep(objPtr) \
((objPtr)->bytes != NULL)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the bignum out of the bignum
* representation of a Tcl_Obj.
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
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; \
(bignum).used = bignumPayload & 0x7FFF; \
} \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
|
| ︙ | ︙ | |||
4611 4612 4613 4614 4615 4616 4617 | * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ | | | | 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 | * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #if TCL_UTF_MAX > 3 #define TclUtfToUniChar(str, chPtr) \ (((UCHAR(*(str))) < 0x80) ? \ ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToChar16(str, chPtr)) #endif |
| ︙ | ︙ | |||
4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 |
while (_i && (*_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
| > > > > > | 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 |
while (_i && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
_count += Tcl_NumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
#define TclUtfPrev(src, start) \
(((src) < (start) + 2) ? (start) : \
((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \
Tcl_UtfPrev(src, start))
/*
*----------------------------------------------------------------
* 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
|
| ︙ | ︙ | |||
4785 4786 4787 4788 4789 4790 4791 | * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG | | | | 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 |
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int 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 TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
|
| ︙ | ︙ | |||
4876 4877 4878 4879 4880 4881 4882 | #endif /* * Macro to use to find the offset of a field in astructure. * Computes number of bytes from beginning of structure to a given field. */ | | | 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 | #endif /* * Macro to use to find the offset of a field in astructure. * Computes number of bytes from beginning of structure to a given field. */ #if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) # define TclOffset(type, field) ((int) offsetof(type, field)) #endif /* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ #ifndef offsetof # define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) #endif |
| ︙ | ︙ | |||
4901 4902 4903 4904 4905 4906 4907 | /* *---------------------------------------------------------------- * Inline version of TclCleanupCommand; still need the function as it is in * the internal stubs, but the core can use the macro instead. */ | | > | | > > | > > > > > > > > > > > > > > > > > | 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 |
/*
*----------------------------------------------------------------
* 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) { \
ckfree(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) { \
ckfree(((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)
|
| ︙ | ︙ | |||
4967 4968 4969 4970 4971 4972 4973 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
| | | | 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
*(void **)&memPtr = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
TclIncrObjsFreed(); \
} while (0)
#else /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
*(void **)&memPtr = (void *) _objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ | | | | | 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 |
EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int flags);
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* Slot 67 is reserved */
/* Slot 68 is reserved */
/* 69 */
EXTERN void * TclpAlloc(unsigned int size);
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
/* 74 */
EXTERN void TclpFree(void *ptr);
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
TCL_DEPRECATED("")
void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
EXTERN void * TclpRealloc(void *ptr, unsigned int size);
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 | EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ | | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 | EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, int length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, |
| ︙ | ︙ | |||
655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN void TclUnusedStubEntry(void);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
| > > > | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 |
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *lengthPtr);
/* 260 */
EXTERN void TclUnusedStubEntry(void);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */
int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */
void (*reserved65)(void);
void (*reserved66)(void);
void (*reserved67)(void);
void (*reserved68)(void);
| | | | | 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 |
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */
int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */
void (*reserved65)(void);
void (*reserved66)(void);
void (*reserved67)(void);
void (*reserved68)(void);
void * (*tclpAlloc) (unsigned int size); /* 69 */
void (*reserved70)(void);
void (*reserved71)(void);
void (*reserved72)(void);
void (*reserved73)(void);
void (*tclpFree) (void *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
void * (*tclpRealloc) (void *ptr, unsigned int size); /* 81 */
void (*reserved82)(void);
void (*reserved83)(void);
void (*reserved84)(void);
void (*reserved85)(void);
void (*reserved86)(void);
void (*reserved87)(void);
TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */
void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
| | > | | 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 |
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */
void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */
Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 259 */
void (*tclUnusedStubEntry) (void); /* 260 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 | (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */ #define TclResetRewriteEnsemble \ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ | | | > > | | 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 | (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */ #define TclResetRewriteEnsemble \ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */ #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetChildCancelFlags \ (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */ #define TclRegisterLiteral \ (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #define TclPtrGetVar \ (tclIntStubsPtr->tclPtrGetVar) /* 252 */ #define TclPtrSetVar \ (tclIntStubsPtr->tclPtrSetVar) /* 253 */ #define TclPtrIncrObjVar \ (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ #define TclPtrObjMakeUpvar \ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclGetBytesFromObj \ (tclIntStubsPtr->tclGetBytesFromObj) /* 259 */ #define TclUnusedStubEntry \ (tclIntStubsPtr->tclUnusedStubEntry) /* 260 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT |
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 1409 1410 | # undef TclGetCommandFromObj # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld # undef Tcl_StaticPackage # define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) #endif #endif /* _TCLINTDECLS */ | > > > > > | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 | # undef TclGetCommandFromObj # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld # undef Tcl_StaticPackage # define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) #endif #undef TclGuessPackageName #ifndef TCL_NO_DEPRECATED # define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) #endif #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | > > > | > > > | > > > | > > > > | > > | > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 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 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ EXTERN struct tm * TclpGmtime_unix(const time_t *clock); /* 13 */ EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 16 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 17 */ EXTERN int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 18 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ |
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ |
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | > | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ |
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
| | | | | | | | | 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 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
| | | | 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 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | > | | | | | > > > > > < > > | 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 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclpLocaltime_unix \ (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ #define TclpGmtime_unix \ (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ |
| ︙ | ︙ | |||
484 485 486 487 488 489 490 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | > | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ |
| ︙ | ︙ | |||
515 516 517 518 519 520 521 | (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | > | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ |
| ︙ | ︙ | |||
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 | #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt # undef TclWinGetPlatformId # undef TclWinResetInterfaces # undef TclWinSetInterfaces # if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TclWinNToHS ntohs # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt # define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ # define TclWinResetInterfaces() /* nop */ # define TclWinSetInterfaces(dummy) /* nop */ # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid | > > > > > > > > > > | | 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 | #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt # undef TclWinGetPlatformId # undef TclWinResetInterfaces # undef TclWinSetInterfaces # if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TclWinNToHS ntohs # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt # define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ # define TclWinResetInterfaces() /* nop */ # define TclWinSetInterfaces(dummy) /* nop */ # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((int)(size_t)(pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
1 2 3 4 5 6 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | /* Forward declaration */ struct Target; /* * struct Alias: * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
/* Forward declaration */
struct Target;
/*
* struct Alias:
*
* Stores information about an alias. Is stored in the child interpreter and
* used by the source command to find the target command in the parent when
* the source command is invoked.
*/
typedef struct Alias {
Tcl_Obj *token; /* Token for the alias command in the child
* interp. This used to be the command name in
* the child when the alias was first
* created. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
Tcl_Command childCmd; /* Source command in child interpreter, bound
* to command that invokes the target command
* in the target interpreter. */
Tcl_HashEntry *aliasEntryPtr;
/* Entry for the alias hash table in child.
* 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. */
int 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
* the structure, which will be extended to
* accomodate the remaining objects in the
* prefix. */
} Alias;
/*
*
* struct Child:
*
* Used by the "interp" command to record and find information about child
* interpreters. Maps from a command name in the parent to information about a
* child interpreter, e.g. what aliases are defined in it.
*/
typedef struct Child {
Tcl_Interp *parentInterp; /* Parent interpreter for this child. */
Tcl_HashEntry *childEntryPtr;
/* Hash entry in parents child table for this
* child interpreter. Used to find this
* record, and used when deleting the child
* interpreter to delete it from the parent's
* table. */
Tcl_Interp *childInterp; /* The child interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands in
* child interpreter to struct Alias defined
* below. */
} Child;
/*
* struct Target:
*
* Maps from parent interpreter commands back to the source commands in child
* interpreters. This is needed because aliases can be created between sibling
* interpreters and must be deleted when the target interpreter is deleted. In
* case they would not be deleted the source interpreter would be left with a
* "dangling pointer". One such record is stored in the Parent record of the
* parent interpreter with the parent for each alias which directs to a
* command in the parent. These records are used to remove the source command
* for an from a child if/when the parent is deleted. They are organized in a
* doubly-linked list attached to the parent interpreter.
*/
typedef struct Target {
Tcl_Command childCmd; /* Command for alias in child interp. */
Tcl_Interp *childInterp; /* Child Interpreter. */
struct Target *nextPtr; /* Next in list of target records, or NULL if
* at the end of the list of targets. */
struct Target *prevPtr; /* Previous in list of target records, or NULL
* if at the start of the list of targets. */
} Target;
/*
* struct Parent:
*
* This record is used for two purposes: First, childTable (a hashtable) maps
* from names of commands to child interpreters. This hashtable is used to
* store information about child interpreters of this interpreter, to map over
* all children, etc. The second purpose is to store information about all
* aliases in children (or siblings) which direct to target commands in this
* interpreter (using the targetsPtr doubly-linked list).
*
* NB: the flags field in the interp structure, used with SAFE_INTERP mask
* denotes whether the interpreter is safe or not. Safe interpreters have
* restricted functionality, can only create safe interpreters and can
* only load safe extensions.
*/
typedef struct Parent {
Tcl_HashTable childTable; /* Hash table for child interpreters. Maps
* from command names to Child records. */
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.
*/
typedef struct InterpInfo {
Parent parent; /* Keeps track of all interps for which this
* interp is the Parent. */
Child child; /* Information necessary for this interp to
* function as a child. */
} InterpInfo;
/*
* Limit callbacks handled by scripts are modelled as structures which are
* stored in hashes indexed by a two-word key. Note that the type of the
* 'type' field in the key is not int; this is to make sure that things are
* likely to work properly on 64-bit architectures.
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, | | | | | | < < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | /* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, Tcl_Interp *childInterp, Tcl_Interp *parentInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int 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, int objc, Tcl_Obj *const objv[]); static Tcl_InterpDeleteProc InterpInfoDeleteProc; static int ChildBgerror(Tcl_Interp *interp, Tcl_Interp *childInterp, int 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, int objc, Tcl_Obj *const objv[]); static int ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static int ChildExpose(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); static int ChildHide(Tcl_Interp *interp, Tcl_Interp *childInterp, int 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, int 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, int objc, Tcl_Obj *const objv[]); static int ChildCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *childInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); static int ChildTimeLimitCmd(Tcl_Interp *interp, Tcl_Interp *childInterp, int consumedObjc, int 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(ClientData clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); /* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; static Tcl_ObjCmdProc NRInterpCmd; static Tcl_ObjCmdProc NRChildCmd; /* *---------------------------------------------------------------------- * * TclSetPreInitScript -- * |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
} PkgName;
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
PkgName pkgName = {NULL, "Tcl"};
| | | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
} PkgName;
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
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, -1, 0) == TCL_ERROR) {
goto end;
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 | } /* *--------------------------------------------------------------------------- * * TclInterpInit -- * | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | > > > > > > > > > | < | | | | | | < | | > > > | | | | | | | | | | | | | | | | | | | 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 |
}
/*
*---------------------------------------------------------------------------
*
* TclInterpInit --
*
* Initializes the invoking interpreter for using the parent, child and
* safe interp facilities. This is called from inside Tcl_CreateInterp().
*
* Results:
* Always returns TCL_OK for backwards compatibility.
*
* Side effects:
* Adds the "interp" command to an interpreter and initializes the
* interpInfoPtr field of the invoking interpreter.
*
*---------------------------------------------------------------------------
*/
int
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Parent *parentPtr;
Child *childPtr;
interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
parentPtr = &interpInfoPtr->parent;
Tcl_InitHashTable(&parentPtr->childTable, TCL_STRING_KEYS);
parentPtr->targetsPtr = NULL;
childPtr = &interpInfoPtr->child;
childPtr->parentInterp = NULL;
childPtr->childEntryPtr = NULL;
childPtr->childInterp = interp;
childPtr->interpCmd = NULL;
Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS);
Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
NULL, NULL);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* InterpInfoDeleteProc --
*
* Invoked when an interpreter is being deleted. It releases all storage
* used by the parent/child/safe interpreter facilities.
*
* Results:
* None.
*
* Side effects:
* Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.
*
*---------------------------------------------------------------------------
*/
static void
InterpInfoDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
InterpInfo *interpInfoPtr;
Child *childPtr;
Parent *parentPtr;
Target *targetPtr;
interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
/*
* 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) {
/*
* Tcl_DeleteInterp() was called on this interpreter, rather "interp
* delete" or the equivalent deletion of the command in the parent.
* First ensure that the cleanup callback doesn't try to delete the
* interp again.
*/
childPtr->childInterp = NULL;
Tcl_DeleteCommandFromToken(childPtr->parentInterp,
childPtr->interpCmd);
}
/*
* There shouldn't be any aliases left.
*/
if (childPtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&childPtr->aliasTable);
ckfree(interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InterpObjCmd --
*
* This function is invoked to process the "interp" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_InterpObjCmd(
ClientData 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;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit",
"share", "slaves", "target", "transfer",
NULL
};
static const char *const optionsNoSlaves[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
"share", "target", "transfer", NULL
};
enum interpOptionEnum {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE,
OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(NULL, objv[1], options,
"option", 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 ((enum interpOptionEnum)index) {
case OPT_ALIAS: {
Tcl_Interp *parentInterp;
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"childPath childCmd ?parentPath parentCmd? ?arg ...?");
return TCL_ERROR;
}
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);
}
goto aliasArgs;
}
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 i, flags;
Tcl_Obj *resultObjPtr;
static const char *const cancelOptions[] = {
"-unwind", "--", NULL
};
enum optionCancelEnum {
OPT_UNWIND, OPT_LAST
};
flags = 0;
for (i = 2; i < objc; i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum optionCancelEnum) index) {
case OPT_UNWIND:
/*
* The evaluation stack in the target interp is to be unwound.
*/
flags |= TCL_CANCEL_UNWIND;
break;
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 |
if (i < objc - 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
return TCL_ERROR;
}
/*
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
if (i < objc - 2) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-unwind? ?--? ?path? ?result?");
return TCL_ERROR;
}
/*
* Did they specify a child interp to cancel the script in progress
* in? If not, use the current interp.
*/
if (i < objc) {
childInterp = GetInterp(interp, objv[i]);
if (childInterp == NULL) {
return TCL_ERROR;
}
i++;
} else {
childInterp = interp;
}
if (i < objc) {
resultObjPtr = objv[i];
/*
* Tcl_CancelEval removes this reference.
*/
Tcl_IncrRefCount(resultObjPtr);
i++;
} else {
resultObjPtr = NULL;
}
return Tcl_CancelEval(childInterp, resultObjPtr, 0, flags);
}
case OPT_CREATE: {
int i, last, safe;
Tcl_Obj *childPtr;
char buf[16 + TCL_INTEGER_SPACE];
static const char *const createOptions[] = {
"-safe", "--", NULL
};
enum option {
OPT_SAFE, OPT_LAST
};
safe = Tcl_IsSafe(interp);
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
childPtr = NULL;
last = 0;
for (i = 2; i < objc; i++) {
if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == OPT_SAFE) {
safe = 1;
continue;
}
i++;
last = 1;
}
if (childPtr != NULL) {
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
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.
*/
for (i = 0; ; i++) {
Tcl_CmdInfo cmdInfo;
sprintf(buf, "interp%d", i);
if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
break;
}
}
childPtr = Tcl_NewStringObj(buf, -1);
}
if (ChildCreate(interp, childPtr, safe) == NULL) {
if (buf[0] != '\0') {
Tcl_DecrRefCount(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: {
int i;
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", NULL);
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
Tcl_DeleteCommandFromToken(iiPtr->child.parentInterp,
iiPtr->child.interpCmd);
}
return TCL_OK;
}
case OPT_EVAL:
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildEval(interp, childInterp, objc - 3, objv + 3);
case OPT_EXISTS: {
int exists = 1;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
if (objc > 3) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
exists = 0;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
return TCL_OK;
}
case OPT_EXPOSE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildExpose(interp, childInterp, objc - 3, objv + 3);
case OPT_HIDE:
if ((objc < 4) || (objc > 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildHide(interp, childInterp, objc - 3, objv + 3);
case OPT_HIDDEN:
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildHidden(interp, childInterp);
case OPT_ISSAFE:
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: {
int i;
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
| | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | 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 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildInvokeHidden(interp, childInterp, namespaceName, objc - i,
objv + i);
}
case OPT_LIMIT: {
static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
};
int limitType;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"path limitType ?-option value ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildMarkTrusted(interp, childInterp);
case OPT_RECLIMIT:
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
case OPT_CHILDREN:
case OPT_SLAVES: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hashSearch;
char *string;
childInterp = GetInterp2(interp, objc, objv);
if (childInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
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 channelId destPath");
return TCL_ERROR;
}
parentInterp = GetInterp(interp, objv[2]);
if (parentInterp == NULL) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(parentInterp, TclGetString(objv[3]), NULL);
if (chan == NULL) {
Tcl_TransferResult(parentInterp, TCL_OK, interp);
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[4]);
if (childInterp == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(childInterp, chan);
if (index == OPT_TRANSFER) {
/*
* When transferring, as opposed to sharing, we must unhitch the
* channel from the interpreter where it started.
*/
if (Tcl_UnregisterChannel(parentInterp, chan) != TCL_OK) {
Tcl_TransferResult(parentInterp, TCL_OK, interp);
return TCL_ERROR;
}
}
return TCL_OK;
}
case OPT_TARGET: {
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
const char *aliasName;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "path alias");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
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, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 | * * Creates an alias between two interpreters. * * Results: * A standard Tcl result. * * Side effects: | | | | | | | | | | | | 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 |
*
* Creates an alias between two interpreters.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a new alias, manipulates the result field of childInterp.
*
*----------------------------------------------------------------------
*/
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. */
int argc, /* How many additional arguments? */
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int 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);
targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
Tcl_IncrRefCount(targetObjPtr);
result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
targetObjPtr, argc, objv);
for (i = 0; i < argc; i++) {
Tcl_DecrRefCount(objv[i]);
}
TclStackFree(childInterp, objv);
Tcl_DecrRefCount(targetObjPtr);
Tcl_DecrRefCount(childObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 | * Creates a new alias. * *---------------------------------------------------------------------- */ int Tcl_CreateAliasObj( | | | | | | | | | 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 |
* Creates a new alias.
*
*----------------------------------------------------------------------
*/
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. */
int 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
| | | | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, 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, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int objc;
Tcl_Obj **objv;
| | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
{
InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int 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, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
|
| ︙ | ︙ | |||
1424 1425 1426 1427 1428 1429 1430 |
/*
* 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.
*/
| | | | 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 |
/*
* 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.
*/
if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
/*
* The child interpreter can be deleted while creating the alias.
* [Bug #641195]
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot define or rename alias \"%s\": interpreter deleted",
Tcl_GetCommandName(cmdInterp, cmd)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 |
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
| | < < | | | | | | | | | | | | | | | | | | | | | 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 |
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *)aliasCmdPtr->objClientData;
}
}
/*
*----------------------------------------------------------------------
*
* AliasCreate --
*
* Helper function to do the work to actually create an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* An alias command is created and entered into the alias table for the
* child interpreter.
*
*----------------------------------------------------------------------
*/
static int
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 *targetNamePtr, /* Name of target cmd. */
int 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, i;
aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = parentInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetNamePtr;
Tcl_IncrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
Tcl_Preserve(childInterp);
Tcl_Preserve(parentInterp);
if (childInterp == parentInterp) {
aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp,
TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
aliasPtr, AliasObjCmdDeleteProc);
} else {
aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, childInterp,
aliasPtr->childCmd) != TCL_OK) {
/*
* Found an alias loop! The last call to Tcl_CreateObjCommand made the
* alias point to itself. Delete the command and its alias record. Be
* 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(targetNamePtr);
for (i = 0; i < objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
cmdPtr = (Command *) aliasPtr->childCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd);
ckfree(aliasPtr);
/*
* The result was already set by TclPreventAliasLoop.
*/
Tcl_Release(childInterp);
Tcl_Release(parentInterp);
return TCL_ERROR;
}
/*
* Make an entry in the alias table. If it already exists, retry.
*/
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
while (1) {
Tcl_Obj *newToken;
const char *string;
string = TclGetString(aliasPtr->token);
hPtr = Tcl_CreateHashEntry(&childPtr->aliasTable, string, &isNew);
if (isNew != 0) {
break;
}
/*
* The alias name cannot be used as unique token, it is already taken.
* We can produce a unique token by prepending "::" repeatedly. This
|
| ︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 |
* 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"...
*/
| | | | | | | | | | | | | | | | | | | | | 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 |
* 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 *)ckalloc(sizeof(Target));
targetPtr->childCmd = aliasPtr->childCmd;
targetPtr->childInterp = childInterp;
parentPtr = &((InterpInfo*) ((Interp*) parentInterp)->interpInfo)->parent;
targetPtr->nextPtr = parentPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (parentPtr->targetsPtr != NULL) {
parentPtr->targetsPtr->prevPtr = targetPtr;
}
parentPtr->targetsPtr = targetPtr;
aliasPtr->targetPtr = targetPtr;
Tcl_SetObjResult(interp, aliasPtr->token);
Tcl_Release(childInterp);
Tcl_Release(parentInterp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDelete --
*
* Deletes the given alias from the child interpreter given.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Deletes the alias from the child interpreter.
*
*----------------------------------------------------------------------
*/
static int
AliasDelete(
Tcl_Interp *interp, /* Interpreter for result & errors. */
Tcl_Interp *childInterp, /* Interpreter containing alias. */
Tcl_Obj *namePtr) /* Name of alias to delete. */
{
Child *childPtr;
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
/*
* 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 = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->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), NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasDescribe --
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 |
*
*----------------------------------------------------------------------
*/
static int
AliasDescribe(
Tcl_Interp *interp, /* Interpreter for result & errors. */
| | | | | | | | | | | > | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
static int
AliasDescribe(
Tcl_Interp *interp, /* Interpreter for result & errors. */
Tcl_Interp *childInterp, /* Interpreter containing alias. */
Tcl_Obj *namePtr) /* Name of alias to describe. */
{
Child *childPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
Tcl_Obj *prefixPtr;
/*
* 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 = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
hPtr = Tcl_FindHashEntry(&childPtr->aliasTable, Tcl_GetString(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;
}
/*
*----------------------------------------------------------------------
*
* AliasList --
*
* Computes a list of aliases defined in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AliasList(
Tcl_Interp *interp, /* Interp for data return. */
Tcl_Interp *childInterp) /* Interp whose aliases to compute. */
{
Tcl_HashEntry *entryPtr;
Tcl_HashSearch hashSearch;
Tcl_Obj *resultPtr;
Alias *aliasPtr;
Child *childPtr;
TclNewObj(resultPtr);
childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->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;
}
/*
*----------------------------------------------------------------------
*
* TclAliasObjCmd, TclLocalAliasObjCmd --
*
* This is the function that services invocations of aliases in a child
* interpreter. One such command exists for each alias. When invoked,
* this function redirects the invocation to the target command in the
* parent interpreter as designated by the Alias record associated with
* this command.
*
* TclLocalAliasObjCmd is a stripped down version used when the source
* and target interpreters of the alias are the same. That lets a number
* of safety precautions be avoided: the state is much more precisely
* known.
*
|
| ︙ | ︙ | |||
1808 1809 1810 1811 1812 1813 1814 |
static int
AliasNRCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
| | | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 |
static int
AliasNRCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Alias *aliasPtr = (Alias *)clientData;
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
List *listRep;
int flags = TCL_EVAL_INVOKE;
/*
|
| ︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 |
TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
| | | | 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 |
TclAliasObjCmd(
ClientData 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, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
Interp *tPtr = (Interp *) targetInterp;
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);
|
| ︙ | ︙ | |||
1948 1949 1950 1951 1952 1953 1954 |
TclLocalAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
| | | | 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 |
TclLocalAliasObjCmd(
ClientData 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, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
Interp *iPtr = (Interp *) interp;
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]);
|
| ︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 | } /* *---------------------------------------------------------------------- * * AliasObjCmdDeleteProc -- * | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* AliasObjCmdDeleteProc --
*
* Is invoked when an alias command is deleted in a child. Cleans up all
* storage associated with this alias.
*
* Results:
* None.
*
* Side effects:
* Deletes the alias record and its entry in the alias table for the
* interpreter.
*
*----------------------------------------------------------------------
*/
static void
AliasObjCmdDeleteProc(
ClientData clientData) /* The alias record for this alias. */
{
Alias *aliasPtr = (Alias *)clientData;
Target *targetPtr;
int 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 = &((InterpInfo *) ((Interp *)
aliasPtr->targetInterp)->interpInfo)->parent;
parentPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
ckfree(targetPtr);
ckfree(aliasPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChild --
*
* Creates a child interpreter. The childPath argument denotes the name
* of the new child relative to the current interpreter; the child is a
* direct descendant of the one-before-last component of the path,
* e.g. it is a descendant of the current interpreter if the childPath
* argument contains only one component. Optionally makes the child
* interpreter safe.
*
* Results:
* Returns the interpreter structure created, or NULL if an error
* occurred.
*
* Side effects:
* Creates a new interpreter and a new interpreter object command in the
* interpreter indicated by the childPath argument.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_CreateChild(
Tcl_Interp *interp, /* Interpreter to start search at. */
const char *childPath, /* Name of child to create. */
int isSafe) /* Should new child be "safe" ? */
{
Tcl_Obj *pathPtr;
Tcl_Interp *childInterp;
pathPtr = Tcl_NewStringObj(childPath, -1);
childInterp = ChildCreate(interp, pathPtr, isSafe);
Tcl_DecrRefCount(pathPtr);
return childInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChild --
*
* Finds a child interpreter by its path name.
*
* Results:
* Returns a Tcl_Interp * for the named interpreter or NULL if not found.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetChild(
Tcl_Interp *interp, /* Interpreter to start search from. */
const char *childPath) /* Path of child to find. */
{
Tcl_Obj *pathPtr;
Tcl_Interp *childInterp;
pathPtr = Tcl_NewStringObj(childPath, -1);
childInterp = GetInterp(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return childInterp;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetParent --
*
* Finds the parent interpreter of a child interpreter.
*
* Results:
* Returns a Tcl_Interp * for the parent interpreter or NULL if none.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *
Tcl_GetParent(
Tcl_Interp *interp) /* Get the parent of this interpreter. */
{
Child *childPtr; /* Child record of this interpreter. */
if (interp == NULL) {
return NULL;
}
childPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->child;
return childPtr->parentInterp;
}
/*
*----------------------------------------------------------------------
*
* TclSetChildCancelFlags --
*
* This function marks all child interpreters belonging to a given
* interpreter as being canceled or not canceled, depending on the
* provided flags.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclSetChildCancelFlags(
Tcl_Interp *interp, /* Set cancel flags of this interpreter. */
int flags, /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
* supported. */
int force) /* Non-zero to ignore numLevels for the purpose
* of resetting the cancellation flags. */
{
Parent *parentPtr; /* Parent record of given interpreter. */
Tcl_HashEntry *hPtr; /* Search element. */
Tcl_HashSearch hashSearch; /* Search variable. */
Child *childPtr; /* Child record of interpreter. */
Interp *iPtr;
if (interp == NULL) {
return;
}
flags &= (CANCELED | TCL_CANCEL_UNWIND);
parentPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->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) {
TclResetCancellation((Tcl_Interp *) iPtr, force);
} else {
TclSetCancelFlags(iPtr, flags);
}
/*
* Now, recursively handle this for the children of this child
* interpreter.
*/
TclSetChildCancelFlags((Tcl_Interp *) iPtr, flags, force);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetInterpPath --
*
* Sets the result of the asking interpreter to a proper Tcl list
* containing the names of interpreters between the asking and target
* interpreters. The target interpreter must be either the same as the
* asking interpreter or one of its children (including recursively).
*
* Results:
* TCL_OK if the target interpreter is the same as, or a descendant of,
* the asking interpreter; TCL_ERROR else. This way one can distinguish
* between the case where the asking and target interps are the same (an
* empty list is the result, and TCL_OK is returned) and when the target
* is not a descendant of the asking interpreter (in which case the Tcl
* result is an error message and the function returns TCL_ERROR).
*
* Side effects:
* 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 = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
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 --
*
* Helper function to find a child interpreter given a pathname.
*
* Results:
* Returns the child interpreter known by that name in the calling
* interpreter, or NULL if no interpreter known by that name exists.
*
* Side effects:
* Assigns to the pointer variable passed in, if not NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
GetInterp(
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr) /* List object containing name of interp. to
* be found. */
{
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
int 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 = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
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), NULL);
}
return searchInterp;
}
/*
*----------------------------------------------------------------------
*
* ChildBgerror --
*
* Helper function to set/query the background error handling command
* prefix of an interp
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When (objc == 1), childInterp will be set to a new background handler
* of objv[0].
*
*----------------------------------------------------------------------
*/
static int
ChildBgerror(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
int 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", NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(childInterp, objv[0]);
}
Tcl_SetObjResult(interp, TclGetBgErrorHandler(childInterp));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildCreate --
*
* Helper function to do the actual work of creating a child interp and
* new object command. Also optionally makes the new child interpreter
* "safe".
*
* Results:
* Returns the new Tcl_Interp * if successful or NULL if not. If failed,
* the result of the invoking interpreter contains an error message.
*
* Side effects:
* Creates a new child interpreter and a new object command.
*
*----------------------------------------------------------------------
*/
static Tcl_Interp *
ChildCreate(
Tcl_Interp *interp, /* Interp. to start search from. */
Tcl_Obj *pathPtr, /* Path (name) of child to create. */
int safe) /* Should we make it "safe"? */
{
Tcl_Interp *parentInterp, *childInterp;
Child *childPtr;
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
int isNew, objc;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(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 = (InterpInfo *) ((Interp *) parentInterp)->interpInfo;
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 = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->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);
Tcl_SetVar2(childInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
*/
((Interp *) childInterp)->maxNestingDepth =
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
if (Tcl_Init(childInterp) == TCL_ERROR) {
goto error;
}
/*
* This will create the "memory" command in child interpreters if we
* compiled with TCL_MEM_DEBUG, otherwise it does nothing.
*/
Tcl_InitMemory(childInterp);
}
/*
* Inherit the TIP#143 limits.
*/
InheritLimitsFromParent(childInterp, parentInterp);
/*
* The [clock] command presents a safe API, but uses unsafe features in
* its implementation. This means it has to be implemented in safe interps
* as an alias to a version in the (trusted) parent.
*/
if (safe) {
Tcl_Obj *clockObj;
int status;
TclNewLiteralStringObj(clockObj, "clock");
Tcl_IncrRefCount(clockObj);
status = AliasCreate(interp, childInterp, parentInterp, clockObj,
clockObj, 0, NULL);
Tcl_DecrRefCount(clockObj);
if (status != TCL_OK) {
goto error2;
}
}
return childInterp;
error:
Tcl_TransferResult(childInterp, TCL_ERROR, interp);
error2:
Tcl_DeleteInterp(childInterp);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclChildObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See user documentation for details.
*
*----------------------------------------------------------------------
*/
int
TclChildObjCmd(
ClientData 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(
ClientData 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;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "debug",
"eval", "expose", "hide", "hidden",
"issafe", "invokehidden", "limit", "marktrusted",
"recursionlimit", NULL
};
enum childCmdOptionsEnum {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG,
OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN,
OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED,
OPT_RECLIMIT
};
if (childInterp == NULL) {
Tcl_Panic("TclChildObjCmd: interpreter has been deleted");
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum childCmdOptionsEnum) index) {
case OPT_ALIAS:
if (objc > 2) {
if (objc == 3) {
return AliasDescribe(interp, childInterp, objv[2]);
}
if (TclGetString(objv[3])[0] == '\0') {
if (objc == 4) {
return AliasDelete(interp, childInterp, objv[2]);
}
} else {
return AliasCreate(interp, childInterp, interp, objv[2],
objv[3], objc - 4, objv + 4);
}
}
Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
return TCL_ERROR;
case OPT_ALIASES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return AliasList(interp, childInterp);
case OPT_BGERROR:
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
return TCL_ERROR;
}
return ChildBgerror(interp, childInterp, objc - 2, objv + 2);
case OPT_DEBUG:
/*
* TIP #378
* Currently only -frame supported, otherwise ?-option ?value? ...?
*/
if (objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??");
return TCL_ERROR;
}
return ChildDebugCmd(interp, childInterp, objc - 2, objv + 2);
case OPT_EVAL:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
return TCL_ERROR;
}
return ChildEval(interp, childInterp, objc - 2, objv + 2);
case OPT_EXPOSE:
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
return ChildExpose(interp, childInterp, objc - 2, objv + 2);
case OPT_HIDE:
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
return ChildHide(interp, childInterp, objc - 2, objv + 2);
case OPT_HIDDEN:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return ChildHidden(interp, childInterp);
case OPT_ISSAFE:
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: {
int i;
const char *namespaceName;
static const char *const hiddenOptions[] = {
"-global", "-namespace", "--", NULL
};
|
| ︙ | ︙ | |||
2679 2680 2681 2682 2683 2684 2685 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
| | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 |
}
}
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-namespace ns? ?-global? ?--? cmd ?arg ..?");
return TCL_ERROR;
}
return ChildInvokeHidden(interp, childInterp, namespaceName,
objc - i, objv + i);
}
case OPT_LIMIT: {
static const char *const limitTypes[] = {
"commands", "time", NULL
};
enum LimitTypes {
|
| ︙ | ︙ | |||
2701 2702 2703 2704 2705 2706 2707 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return ChildMarkTrusted(interp, childInterp);
case OPT_RECLIMIT:
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ChildObjCmdDeleteProc --
*
* Invoked when an object command for a child interpreter is deleted;
* cleans up all state associated with the child interpreter and destroys
* the child interpreter.
*
* Results:
* None.
*
* Side effects:
* Cleans up all state associated with the child interpreter and destroys
* the child interpreter.
*
*----------------------------------------------------------------------
*/
static void
ChildObjCmdDeleteProc(
ClientData 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 = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child;
/*
* Unlink the child from its parent interpreter.
*/
Tcl_DeleteHashEntry(childPtr->childEntryPtr);
/*
* Set to NULL so that when the InterpInfo is cleaned up in the child it
* does not try to delete the command causing all sorts of grief. See
* ChildRecordDeleteProc().
*/
childPtr->interpCmd = NULL;
if (childPtr->childInterp != NULL) {
Tcl_DeleteInterp(childPtr->childInterp);
}
}
/*
*----------------------------------------------------------------------
*
* ChildDebugCmd -- TIP #378
*
* Helper function to handle 'debug' command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May modify INTERP_DEBUG_FRAME flag in the child.
*
*----------------------------------------------------------------------
*/
static int
ChildDebugCmd(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const debugTypes[] = {
"-frame", NULL
};
enum DebugTypes {
DEBUG_TYPE_FRAME
};
int debugType;
Interp *iPtr;
Tcl_Obj *resultPtr;
iPtr = (Interp *) childInterp;
if (objc == 0) {
TclNewObj(resultPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj("-frame", -1));
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
Tcl_SetObjResult(interp, resultPtr);
} else {
if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
|
| ︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildEval --
*
* Helper function to evaluate a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the command does.
*
*----------------------------------------------------------------------
*/
static int
ChildEval(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* The child interpreter in which command
* will be evaluated. */
int 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
* can result in a situation where a child interpreter can no longer
* evaluate any scripts unless somebody calls the TclResetCancellation
* function for that particular Tcl_Interp.
*/
TclSetChildCancelFlags(childInterp, 0, 0);
Tcl_Preserve(childInterp);
Tcl_AllowExceptions(childInterp);
if (objc == 1) {
/*
* TIP #280: Make actual argument location available to eval'd script.
*/
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = iPtr->cmdFramePtr;
int word = 0;
TclArgumentGet(interp, objv[0], &invoker, &word);
result = TclEvalObjEx(childInterp, objv[0], 0, invoker, word);
} else {
Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(childInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
Tcl_TransferResult(childInterp, result, interp);
Tcl_Release(childInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
* ChildExpose --
*
* Helper function to expose a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the child will be able to invoke the newly
* exposed command.
*
*----------------------------------------------------------------------
*/
static int
ChildExpose(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
int 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",
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);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildRecursionLimit --
*
* Helper function to set/query the Recursion limit of an interp
*
* Results:
* A standard Tcl result.
*
* Side effects:
* When (objc == 1), childInterp will be set to a new recursion limit of
* objv[0].
*
*----------------------------------------------------------------------
*/
static int
ChildRecursionLimit(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which limit is set/queried. */
int objc, /* Set or Query. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
Interp *iPtr;
int limit;
if (objc) {
|
| ︙ | ︙ | |||
2995 2996 2997 2998 2999 3000 3001 |
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
NULL);
return TCL_ERROR;
}
| | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
if (limit <= 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
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", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* ChildHide --
*
* Helper function to hide a command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call scripts in the child will no longer be able to invoke
* the named command.
*
*----------------------------------------------------------------------
*/
static int
ChildHide(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp, /* Interp in which command will be exposed. */
int 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",
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;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ChildHidden --
*
* Helper function to compute list of hidden commands in a child
* interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
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;
}
/*
*----------------------------------------------------------------------
*
* ChildInvokeHidden --
*
* Helper function to invoke a hidden command in a child interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Whatever the hidden command does.
*
*----------------------------------------------------------------------
*/
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. */
int 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",
NULL);
return TCL_ERROR;
}
Tcl_Preserve(childInterp);
Tcl_AllowExceptions(childInterp);
if (namespaceName == NULL) {
NRE_callback *rootPtr = TOP_CB(childInterp);
Tcl_NRAddCallback(interp, NRPostInvokeHidden, childInterp,
rootPtr, NULL, NULL);
return TclNRInvoke(NULL, childInterp, objc, objv);
} else {
Namespace *nsPtr, *dummy1, *dummy2;
const char *tail;
result = TclGetNamespaceForQualName(childInterp, namespaceName, NULL,
TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG
| TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if (result == TCL_OK) {
result = TclObjInvokeNamespace(childInterp, objc, objv,
(Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
}
}
Tcl_TransferResult(childInterp, result, interp);
Tcl_Release(childInterp);
return result;
}
static int
NRPostInvokeHidden(
ClientData 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;
}
/*
*----------------------------------------------------------------------
*
* ChildMarkTrusted --
*
* Helper function to mark a child interpreter as trusted (unsafe).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* After this call the hard-wired security checks in the core no longer
* prevent the child from performing certain operations.
*
*----------------------------------------------------------------------
*/
static int
ChildMarkTrusted(
Tcl_Interp *interp, /* Interp for error return. */
Tcl_Interp *childInterp) /* The child interpreter which will be marked
* 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",
NULL);
return TCL_ERROR;
}
((Interp *) childInterp)->flags &= ~SAFE_INTERP;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsSafe --
|
| ︙ | ︙ | |||
3264 3265 3266 3267 3268 3269 3270 |
int
Tcl_MakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
Interp *iPtr = (Interp *) interp;
| | | | | | | 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 |
int
Tcl_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 = ((InterpInfo*) iPtr->interpInfo)->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 {}}", -1, 0);
}
iPtr->flags |= SAFE_INTERP;
/*
* Unsetting variables : (which should not have been set in the first
* place, but...)
*/
/*
* No env array in a safe interpreter.
*/
Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
*/
|
| ︙ | ︙ | |||
3604 3605 3606 3607 3608 3609 3610 |
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
/*
* Allocate a handler record.
*/
| | | 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 |
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
/*
* Allocate a handler record.
*/
handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
handlerPtr->deleteProc = deleteProc;
handlerPtr->prevPtr = NULL;
/*
|
| ︙ | ︙ | |||
4061 4062 4063 4064 4065 4066 4067 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
ClientData clientData)
{
| | | | 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
ClientData 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
|
| ︙ | ︙ | |||
4189 4190 4191 4192 4193 4194 4195 | /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * * Callback for when a script limit (a limit callback implemented as a | | | | 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 |
/*
*----------------------------------------------------------------------
*
* DeleteScriptLimitCallback --
*
* Callback for when a script limit (a limit callback implemented as a
* Tcl script in a parent interpreter, as set up from Tcl) is deleted.
*
* Results:
* None.
*
* Side effects:
* The reference to the script callback from the controlling interpreter
* is removed.
*
*----------------------------------------------------------------------
*/
static void
DeleteScriptLimitCallback(
ClientData clientData)
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
ckfree(limitCBPtr);
}
|
| ︙ | ︙ | |||
4235 4236 4237 4238 4239 4240 4241 |
*
*----------------------------------------------------------------------
*/
static void
CallScriptLimitCallback(
ClientData clientData,
| | | < | 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 |
*
*----------------------------------------------------------------------
*/
static void
CallScriptLimitCallback(
ClientData 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,
TCL_EVAL_GLOBAL);
|
| ︙ | ︙ | |||
4306 4307 4308 4309 4310 4311 4312 |
}
return;
}
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
| | | | 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 |
}
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 *)ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
limitCBPtr->type = type;
Tcl_IncrRefCount(scriptObj);
Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
|
| ︙ | ︙ | |||
4403 4404 4405 4406 4407 4408 4409 |
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(ScriptLimitCallbackKey)/sizeof(int));
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | | | | | | | | | | | | | | | 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 |
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(ScriptLimitCallbackKey)/sizeof(int));
}
/*
*----------------------------------------------------------------------
*
* InheritLimitsFromParent --
*
* Derive the interpreter limit configuration for a child interpreter
* from the limit config for the parent.
*
* Results:
* None.
*
* Side effects:
* The child interpreter limits are set so that if the parent has a
* limit, it may not exceed it by handing off work to child interpreters.
* Note that this does not transfer limit callbacks from the parent to
* the child.
*
*----------------------------------------------------------------------
*/
static void
InheritLimitsFromParent(
Tcl_Interp *childInterp,
Tcl_Interp *parentInterp)
{
Interp *childPtr = (Interp *) childInterp;
Interp *parentPtr = (Interp *) parentInterp;
if (parentPtr->limit.active & TCL_LIMIT_COMMANDS) {
childPtr->limit.active |= TCL_LIMIT_COMMANDS;
childPtr->limit.cmdCount = 0;
childPtr->limit.cmdGranularity = parentPtr->limit.cmdGranularity;
}
if (parentPtr->limit.active & TCL_LIMIT_TIME) {
childPtr->limit.active |= TCL_LIMIT_TIME;
memcpy(&childPtr->limit.time, &parentPtr->limit.time,
sizeof(Tcl_Time));
childPtr->limit.timeGranularity = parentPtr->limit.timeGranularity;
}
}
/*
*----------------------------------------------------------------------
*
* ChildCommandLimitCmd --
*
* Implementation of the [interp limit $i commands] and [$i limit
* commands] subcommands. See the interp manual page for a full
* description.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Depends on the arguments.
*
*----------------------------------------------------------------------
*/
static int
ChildCommandLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Interp *childInterp, /* Interpreter being adjusted. */
int consumedObjc, /* Number of args already parsed. */
int objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"-command", "-granularity", "-value", NULL
};
|
| ︙ | ︙ | |||
4486 4487 4488 4489 4490 4491 4492 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
| | | | | | | | | | | | | 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* 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", 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, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
} else {
Tcl_Obj *empty;
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[2], -1), 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 ((enum Options) index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &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(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
4612 4613 4614 4615 4616 4617 4618 |
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
}
}
if (scriptObj != NULL) {
| | | | | | | | | | 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 |
"BADVALUE", NULL);
return TCL_ERROR;
}
break;
}
}
if (scriptObj != NULL) {
SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp,
(scriptLen > 0 ? scriptObj : NULL));
}
if (granObj != NULL) {
Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_COMMANDS, gran);
}
if (limitObj != NULL) {
if (limitLen > 0) {
Tcl_LimitSetCommands(childInterp, limit);
Tcl_LimitTypeSet(childInterp, TCL_LIMIT_COMMANDS);
} else {
Tcl_LimitTypeReset(childInterp, TCL_LIMIT_COMMANDS);
}
}
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* ChildTimeLimitCmd --
*
* Implementation of the [interp limit $i time] and [$i limit time]
* subcommands. See the interp manual page for a full description.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Depends on the arguments.
*
*----------------------------------------------------------------------
*/
static int
ChildTimeLimitCmd(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Interp *childInterp, /* Interpreter being adjusted. */
int consumedObjc, /* Number of args already parsed. */
int objc, /* Total number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"-command", "-granularity", "-milliseconds", "-seconds", NULL
};
|
| ︙ | ︙ | |||
4674 4675 4676 4677 4678 4679 4680 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* the low level API enforces this with Tcl_Panic, which we want to
* avoid. [Bug 3398794]
*/
| | | | | | | | 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 |
/*
* First, ensure that we are not reading or writing the calling
* interpreter's limits; it may only manipulate its children. Note that
* 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", 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, (char *) &key);
if (hPtr != NULL) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr);
if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
limitCBPtr->scriptObj);
} else {
goto putEmptyCommandInDict;
}
} else {
Tcl_Obj *empty;
putEmptyCommandInDict:
TclNewObj(empty);
Tcl_DictObjPut(NULL, dictPtr,
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
Tcl_NewWideIntObj(limitMoment.usec/1000));
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
|
| ︙ | ︙ | |||
4733 4734 4735 4736 4737 4738 4739 |
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
| | | | | | | | | | 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 |
} else if (objc == consumedObjc+1) {
if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = childInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &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(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
Tcl_Time limitMoment;
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec));
}
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
int 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;
int 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 ((enum Options) index) {
case OPT_CMD:
|
| ︙ | ︙ | |||
4874 4875 4876 4877 4878 4879 4880 | * incrementing sec in the process. This makes it much easier * for people to write scripts that do small time increments. */ limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; | | | | | | | 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 |
* incrementing sec in the process. This makes it much easier
* for people to write scripts that do small time increments.
*/
limitMoment.sec += limitMoment.usec / 1000000;
limitMoment.usec %= 1000000;
Tcl_LimitSetTime(childInterp, &limitMoment);
Tcl_LimitTypeSet(childInterp, TCL_LIMIT_TIME);
} else {
Tcl_LimitTypeReset(childInterp, TCL_LIMIT_TIME);
}
}
if (scriptObj != NULL) {
SetScriptLimitCallback(interp, TCL_LIMIT_TIME, childInterp,
(scriptLen > 0 ? scriptObj : NULL));
}
if (granObj != NULL) {
Tcl_LimitSetGranularity(childInterp, TCL_LIMIT_TIME, gran);
}
return TCL_OK;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclLink.c.
1 2 3 4 5 6 7 8 | /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright © 1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2008 Rene Zaumseil * Copyright © 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
if (size < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong array size given", -1));
return TCL_ERROR;
}
| | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
if (size < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong array size given", -1));
return TCL_ERROR;
}
linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|| defined(_WIN32) || defined(__CYGWIN__))
if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
linkPtr->type = TCL_LINK_LONG;
} else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
linkPtr->type = TCL_LINK_ULONG;
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 |
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
mp_int *numPtr = (mp_int *)clientData;
Tcl_WideUInt value = 0;
union {
Tcl_WideUInt value;
unsigned char bytes[sizeof(Tcl_WideUInt)];
} scratch;
size_t numBytes;
unsigned char *bytes = scratch.bytes;
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 | /* * Mark an object as holding a weird double. */ static int SetInvalidRealFromAny( | | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
/*
* Mark an object as holding a weird double.
*/
static int
SetInvalidRealFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
str = TclGetString(objPtr);
if ((objPtr->length == 1) && (str[0] == '.')) {
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
| | | > > > | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
/* Links can only be made to global variables,
* so we can find them with need to resolve
* caller-supplied name in caller context. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *)clientData;
int changed;
int valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = TclGetString(valueObj);
valueLength = valueObj->length + 1;
pp = (char **) linkPtr->addr;
| | | | | | | 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 |
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = TclGetString(valueObj);
valueLength = valueObj->length + 1;
pp = (char **) linkPtr->addr;
*pp = (char *)ckrealloc(*pp, valueLength);
memcpy(*pp, value, valueLength);
return NULL;
case TCL_LINK_CHARS:
value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
} else {
linkPtr->lastValue.c = '\0';
LinkedVar(char) = linkPtr->lastValue.c;
}
return NULL;
case TCL_LINK_BINARY:
value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
if (valueLength != linkPtr->bytes) {
return (char *) "wrong size of binary value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
} else {
linkPtr->lastValue.uc = (unsigned char) *value;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
}
return NULL;
}
|
| ︙ | ︙ | |||
1181 1182 1183 1184 1185 1186 1187 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
| | | | 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 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned long value";
}
linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
LinkedVar(unsigned long) = linkPtr->lastValue.ul =
(unsigned long) valueUWide;
}
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
Tcl_Obj *resultObj, **objv;
int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
Tcl_Obj *resultObj, **objv;
int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewWideIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewWideIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewWideIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewWideIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewWideIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
#endif
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
TclNewIntObj(objv[i], (Tcl_WideInt)
linkPtr->lastValue.uwPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
1 2 3 4 5 | /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * Copyright © 2001 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 <assert.h> |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
} while (0)
#define ListGetIntRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclListType); \
| | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
} while (0)
#define ListGetIntRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclListType); \
(listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define ListResetIntRep(objPtr, listRepPtr) \
TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
LIST_SIZE(objc));
}
return NULL;
}
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
| | < | < | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= listLen) {
toIdx = listLen-1;
}
if (fromIdx > toIdx) {
| > > | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= listLen) {
toIdx = listLen-1;
}
if (fromIdx > toIdx) {
Tcl_Obj *obj;
TclNewObj(obj);
return obj;
}
newLen = toIdx - fromIdx + 1;
if (Tcl_IsShared(listPtr) ||
((ListRepPtr(listPtr)->refCount > 1))) {
return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
|
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | 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 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
listRepPtr->maxElemCount = attempt;
needGrow = 0;
}
}
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | 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 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
ListResetIntRep(listPtr, listRepPtr);
elemPtrs = &listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
|
| ︙ | ︙ | |||
1089 1090 1091 1092 1093 1094 1095 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
| | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*));
}
} else {
/*
* Cannot use the current List struct; it is shared, too small, or
* both. Allocate a new struct and insert elements into it.
*/
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 |
* 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; see TIP#22 and TIP#33 for the details.
*/
ListGetIntRep(argPtr, listRepPtr);
if ((listRepPtr == NULL)
| | | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 |
* 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; see TIP#22 and TIP#33 for the details.
*/
ListGetIntRep(argPtr, listRepPtr);
if ((listRepPtr == NULL)
&& TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
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) {
| | | | 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 |
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], INT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
TclNewObj(listPtr);
} else {
/*
* Extract the pointer to the appropriate element.
*/
listPtr = elemPtrs[index];
}
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 |
* Determine whether the index arg designates a list or a single index.
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
ListGetIntRep(indexArgPtr, listRepPtr);
if (listRepPtr == NULL
| | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
* Determine whether the index arg designates a list or a single index.
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
ListGetIntRep(indexArgPtr, listRepPtr);
if (listRepPtr == NULL
&& TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
}
|
| ︙ | ︙ | |||
1602 1603 1604 1605 1606 1607 1608 |
}
indexArray++;
if (index < 0 || index > elemCount
|| (valuePtr == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
| | | | < | | | 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 |
}
indexArray++;
if (index < 0 || index > elemCount
|| (valuePtr == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range", Tcl_GetString(indexArray[-1])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. As long as we're not yet on the last index,
* determine the next sublist for the next pass through the loop, and
* take steps to make sure it is an unshared copy, as we intend to
* modify it.
*/
if (--indexCount) {
parentList = subListPtr;
if (index == elemCount) {
TclNewObj(subListPtr);
} else {
subListPtr = elemPtrs[index];
}
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
}
|
| ︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 | List *listRepPtr; /* * Clear away our intrep surgery mess. */ irPtr = TclFetchIntRep(objPtr, &tclListType); | | | | 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 |
List *listRepPtr;
/*
* Clear away our intrep surgery mess.
*/
irPtr = TclFetchIntRep(objPtr, &tclListType);
listRepPtr = (List *)irPtr->twoPtrValue.ptr1;
chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
if (result == TCL_OK) {
/*
* We're going to store valuePtr, so spoil string reps of all
* containing lists.
*/
|
| ︙ | ︙ | |||
1797 1798 1799 1800 1801 1802 1803 |
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
if (interp != NULL) {
| | | | | | | | | | 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 |
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%d\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
elemCount = listRepPtr->elemCount;
/*
* Ensure that the index is in bounds.
*/
if (index<0 || index>=elemCount) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%d\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
/*
* If the internal rep is shared, replace it with an unshared copy.
*/
|
| ︙ | ︙ | |||
2167 2168 2169 2170 2171 2172 2173 |
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
| | | 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
flagPtr = (char *)ckalloc(numElems);
}
elemPtrs = &listRepPtr->elements;
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 < 0) {
|
| ︙ | ︙ |
Changes to generic/tclLiteral.c.
1 2 3 4 5 6 7 8 9 | /* * tclLiteral.c -- * * Implementation of the global and ByteCode-local literal tables used to * manage the Tcl objects created for literal values during compilation * of Tcl scripts. This implementation borrows heavily from the more * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclLiteral.c -- * * Implementation of the global and ByteCode-local literal tables used to * manage the Tcl objects created for literal values during compilation * of Tcl scripts. This implementation borrows heavily from the more * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. * * Copyright © 1997-1998 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 "tclCompile.h" |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* Release remaining literals in the table. Note that releasing a literal
* might release other literals, modifying the table, so we restart the
* search from the bucket chain we last found an entry.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/
/*
* We used to call TclReleaseLiteral for each literal in the table, which
* is rather inefficient as it causes one lookup-by-hash for each
* reference to the literal. We now rely at interp-deletion on each
* bytecode object to release its references to the literal Tcl_Obj
| > > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* Release remaining literals in the table. Note that releasing a literal
* might release other literals, modifying the table, so we restart the
* search from the bucket chain we last found an entry.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
#else
(void)interp;
#endif /*TCL_COMPILE_DEBUG*/
/*
* We used to call TclReleaseLiteral for each literal in the table, which
* is rather inefficient as it causes one lookup-by-hash for each
* reference to the literal. We now rely at interp-deletion on each
* bytecode object to release its references to the literal Tcl_Obj
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
}
#endif
| | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
}
#endif
globalPtr = (LiteralEntry *)ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
globalTablePtr->buckets[globalHash] = globalPtr;
globalTablePtr->numEntries++;
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
* malloc'd bytes and ownership is passed to
* this function. If LITERAL_CMD_NAME then
* the literal should not be shared accross
* namespaces. */
{
| | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
* malloc'd bytes and ownership is passed to
* this function. If LITERAL_CMD_NAME then
* the literal should not be shared accross
* namespaces. */
{
CompileEnv *envPtr = (CompileEnv *)ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
unsigned hash;
unsigned int localHash;
int objIndex, isNew;
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 |
if (currBytes == newSize) {
Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
if (envPtr->mallocedLiteralArray) {
| | | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 |
if (currBytes == newSize) {
Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
if (envPtr->mallocedLiteralArray) {
newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize);
} else {
/*
* envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
newArrayPtr = (LiteralEntry *)ckalloc(newSize);
memcpy(newArrayPtr, currArrayPtr, currBytes);
envPtr->mallocedLiteralArray = 1;
}
/*
* Update the local literal table's bucket array.
*/
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
| > | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 |
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **)ckalloc(
tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->mask = (tablePtr->mask << 2) + 3;
|
| ︙ | ︙ | |||
1126 1127 1128 1129 1130 1131 1132 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *)ckalloc(NUM_COUNTERS*60 + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i=0 ; i<NUM_COUNTERS ; i++) {
sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
1 2 3 4 5 6 | /* * tclLoad.c -- * * This file provides the generic portion (those that are the same on all * platforms) of Tcl's dynamic loading facilities. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclLoad.c -- * * This file provides the generic portion (those that are the same on all * platforms) of Tcl's dynamic loading facilities. * * 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" |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LoadObjCmd( | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LoadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
Tcl_UniChar ch = 0;
unsigned len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
| | | | | 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 |
Tcl_UniChar ch = 0;
unsigned len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
enum loadOptionsEnum {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
};
while (objc > 2) {
if (TclGetString(objv[1])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
++objv; --objc;
if (LOAD_GLOBAL == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_GLOBAL;
} else if (LOAD_LAZY == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
|
| ︙ | ︙ | |||
192 193 194 195 196 197 198 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
| | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
const char *childIntName = Tcl_GetString(objv[3]);
target = Tcl_GetChild(interp, childIntName);
if (target == NULL) {
code = TCL_ERROR;
goto done;
}
}
/*
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
/*
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then
* there's nothing for us to do.
*/
if (pkgPtr != NULL) {
| | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
/*
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then
* there's nothing for us to do.
*/
if (pkgPtr != NULL) {
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
goto done;
}
}
}
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 |
/*
* Figure out the module name if it wasn't provided explicitly.
*/
if (packageName != NULL) {
Tcl_DStringAppend(&pkgName, packageName, -1);
} else {
| > | > < < < < < < | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | < | 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 |
/*
* Figure out the module name if it wasn't provided explicitly.
*/
if (packageName != NULL) {
Tcl_DStringAppend(&pkgName, packageName, -1);
} else {
Tcl_Obj *splitPtr, *pkgGuessPtr;
int pElements;
const char *pkgGuess;
/*
* Threading note - this call used to be protected by a mutex.
*/
/*
* The platform-specific code couldn't figure out the module
* name. Make a guess by taking the last element of the file
* name, stripping off any leading "lib", and then using all
* of the alphabetic and underline characters that follow
* that.
*/
splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
pkgGuess = Tcl_GetString(pkgGuessPtr);
if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
&& (pkgGuess[2] == 'b')) {
pkgGuess += 3;
}
#ifdef __CYGWIN__
else if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
&& (pkgGuess[2] == 'g')) {
pkgGuess += 3;
}
#endif /* __CYGWIN__ */
if ((pkgGuess[0] == 't') && (pkgGuess[1] == 'c')
&& (pkgGuess[2] == 'l')) {
pkgGuess += 3;
}
for (p = pkgGuess; *p != 0; p += offset) {
offset = TclUtfToUniChar(p, &ch);
if ((ch > 0x100)
|| !(isalpha(UCHAR(ch)) /* INTL: ISO only */
|| (UCHAR(ch) == '_'))) {
break;
}
}
if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't figure out package name for %s",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
"WHATPACKAGE", NULL);
code = TCL_ERROR;
goto done;
}
Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess);
Tcl_DecrRefCount(splitPtr);
}
/*
* Fix the capitalization in the package name so that the first
* character is in caps (or title case) but the others are all
* lower-case.
*/
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 | goto done; } /* * Create a new record to describe this package. */ | | | | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | goto done; } /* * Create a new record to describe this package. */ pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); len = strlen(fullFileName) + 1; pkgPtr->fileName = (char *)ckalloc(len); memcpy(pkgPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pkgName) + 1; pkgPtr->packageName = (char *)ckalloc(len); memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) |
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
Tcl_MutexUnlock(&packageMutex);
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
| | | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
Tcl_MutexUnlock(&packageMutex);
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
done:
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnloadObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target; /* Which interpreter to unload from. */
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp;
Tcl_PackageUnloadProc *unloadProc;
InterpPackage *ipFirstPtr, *ipPtr;
int i, index, code, complain = 1, keepLibrary = 0;
int trustedRefCount = -1, safeRefCount = -1;
const char *fullFileName = "";
const char *packageName;
static const char *const options[] = {
"-nocomplain", "-keeplibrary", "--", NULL
};
enum unloadOptionsEnum {
UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
};
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
fullFileName = Tcl_GetString(objv[i]);
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 | * must clear the error. */ Tcl_ResetResult(interp); break; } } | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 |
* must clear the error.
*/
Tcl_ResetResult(interp);
break;
}
}
switch ((enum unloadOptionsEnum)index) {
case UNLOAD_NOCOMPLAIN: /* -nocomplain */
complain = 0;
break;
case UNLOAD_KEEPLIB: /* -keeplibrary */
keepLibrary = 1;
break;
case UNLOAD_LAST: /* -- */
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
| | | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
const char *childIntName = Tcl_GetString(objv[i + 2]);
target = Tcl_GetChild(interp, childIntName);
if (target == NULL) {
return TCL_ERROR;
}
}
/*
* Scan through the packages that are currently loaded to see if the
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
if (pkgPtr != NULL) {
| | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
if (pkgPtr != NULL) {
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
break;
}
}
}
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 | } } /* * Remove this library from the interpreter's library cache. */ | | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
}
}
/*
* Remove this library from the interpreter's library cache.
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = ipFirstPtr;
if (ipPtr->pkgPtr == defaultPtr) {
ipFirstPtr = ipFirstPtr->nextPtr;
} else {
InterpPackage *ipPrevPtr;
for (ipPrevPtr = ipPtr; ipPtr != NULL;
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
| | | | | | | < < < < < < < < < < < < | | | | 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 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *)ckalloc(1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = (char *)ckalloc(strlen(pkgName) + 1);
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
}
if (interp != NULL) {
/*
* If we're loading the package into an interpreter, determine whether
* it's already loaded.
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
return;
}
}
/*
* Package isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetLoadedPackagesEx --
*
* This function returns information about all of the files that are
* loaded (either in a particular interpreter, or for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If successful, a
* list of lists is placed in the interp's result. Each sublist
* corresponds to one loaded file; its first element is the name of the
* file (or an empty string for something that's statically loaded) and
* the second element is the name of the package in that file.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGetLoadedPackagesEx(
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 *packageName) /* Package name or NULL. If NULL, return info
* for all packages.
*/
{
Tcl_Interp *target;
LoadedPackage *pkgPtr;
InterpPackage *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
TclNewObj(resultObj);
Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
pkgPtr = pkgPtr->nextPtr) {
pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewListObj(2, pkgDesc));
}
Tcl_MutexUnlock(&packageMutex);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
target = Tcl_GetChild(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
/*
* Return information about all of the available packages.
*/
if (packageName) {
resultObj = NULL;
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
}
/*
* Return information about only the packages that are loaded in a given
* interpreter.
*/
| | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 |
}
/*
* Return information about only the packages that are loaded in a given
* interpreter.
*/
TclNewObj(resultObj);
for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
pkgPtr = ipPtr->pkgPtr;
pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
}
Tcl_SetObjResult(interp, resultObj);
|
| ︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 |
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
ClientData clientData, /* Pointer to first InterpPackage structure
* for interp. */
| | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 |
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
ClientData clientData, /* Pointer to first InterpPackage structure
* for interp. */
TCL_UNUSED(Tcl_Interp *))
{
InterpPackage *ipPtr, *nextPtr;
ipPtr = (InterpPackage *)clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
ckfree(ipPtr);
ipPtr = nextPtr;
}
}
|
| ︙ | ︙ |
Changes to generic/tclLoadNone.c.
1 2 3 4 5 6 | /* * tclLoadNone.c -- * * This procedure provides a version of the TclpDlopen for use in * systems that don't support dynamic loading; it just returns an error. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclLoadNone.c -- * * This procedure provides a version of the TclpDlopen for use in * systems that don't support dynamic loading; it just returns an error. * * 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" |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"dynamic loading is not currently available on this system",
-1));
}
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | < | < | 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 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"dynamic loading is not currently available on this system",
-1));
}
return TCL_ERROR;
}
/*
* These functions are fallbacks if we somehow determine that the platform can
* do loading from memory but the user wishes to disable it. They just report
* (gracefully) that they fail.
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int))
{
return NULL;
}
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
TCL_UNUSED(void *),
TCL_UNUSED(int),
TCL_UNUSED(int),
TCL_UNUSED(Tcl_LoadHandle *),
TCL_UNUSED(Tcl_FSUnloadFileProc **),
TCL_UNUSED(int))
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
"is not available on this system", -1));
}
return TCL_ERROR;
}
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * This file contains a generic main program for Tcl shells and other * Tcl-based applications. It can be used as-is for many applications, * just by supplying a different appInitProc function for each specific * application. Or, it can be used as a template for creating new main * programs for Tcl applications. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * This file contains a generic main program for Tcl shells and other * Tcl-based applications. It can be used as-is for many applications, * just by supplying a different appInitProc function for each specific * application. Or, it can be used as a template for creating new main * programs for Tcl applications. * * Copyright © 1988-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with UNICODE and |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | #ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp #endif | | | | 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 |
#ifndef _WIN32
# define TCHAR char
# define TEXT(arg) arg
# define _tcscmp strcmp
#endif
static Tcl_Obj *
NewNativeObj(
TCHAR *string)
{
Tcl_DString ds;
#ifdef UNICODE
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(string, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds);
#endif
return TclDStringToObj(&ds);
}
/*
* Declarations for various library functions and variables (don't want to
* include tclPort.h here, because people might copy this file out of the Tcl
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
TclNewObj(is.commandPtr);
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
| | | | 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 |
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++));
}
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_NewWideIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 | TclGetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); | | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
TclGetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
TclNewObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 | * * Side effects: * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ | < | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
*
* Side effects:
* Could be almost arbitrary, depending on the command that's typed.
*
*----------------------------------------------------------------------
*/
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
TCL_UNUSED(int) /*mask*/)
{
int code, length;
InteractiveState *isPtr = (InteractiveState *)clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
* things, this will trash the text of the command being evaluated.
*/
Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
| > | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
* things, this will trash the text of the command being evaluated.
*/
Tcl_CreateChannelHandler(chan, 0, StdinProc, isPtr);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(commandPtr);
TclNewObj(commandPtr);
isPtr->commandPtr = commandPtr;
Tcl_IncrRefCount(commandPtr);
if (chan != NULL) {
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr);
}
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
*----------------------------------------------------------------------
*/
static void
FreeMainInterp(
ClientData clientData)
{
| | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 |
*----------------------------------------------------------------------
*/
static void
FreeMainInterp(
ClientData clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
/*if (TclInExit()) return;*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
Tcl_SetStartupScript(NULL, NULL);
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
1 2 3 4 5 6 7 8 9 | /* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. * * Copyright © 1993-1997 Lucent Technologies. * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2002-2005 Donal K. Fellows. * Copyright © 2006 Neil Madden. * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | 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(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); | | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | 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 | 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(ClientData 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; static Tcl_ObjCmdProc NamespaceExportCmd; static Tcl_ObjCmdProc NamespaceForgetCmd; static void NamespaceFree(Namespace *nsPtr); static Tcl_ObjCmdProc NamespaceImportCmd; static Tcl_ObjCmdProc NamespaceInscopeCmd; static Tcl_ObjCmdProc NRNamespaceInscopeCmd; static Tcl_ObjCmdProc NamespaceOriginCmd; static Tcl_ObjCmdProc NamespaceParentCmd; static Tcl_ObjCmdProc NamespacePathCmd; static Tcl_ObjCmdProc NamespaceQualifiersCmd; static Tcl_ObjCmdProc NamespaceTailCmd; static Tcl_ObjCmdProc NamespaceUpvarCmd; static Tcl_ObjCmdProc NamespaceUnknownCmd; static Tcl_ObjCmdProc NamespaceWhichCmd; static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); static Tcl_NRPostProc NsEval_Callback; /* * This structure defines a Tcl object type that contains a namespace |
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
} while (0)
#define NsNameGetIntRep(objPtr, nnPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &nsNameType); \
| | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
} while (0)
#define NsNameGetIntRep(objPtr, nnPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((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.
*/
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
* Review of those designs might permit stricter checking here.
*/
if (nsPtr->flags & NS_DEAD) {
Tcl_Panic("Trying to push call frame for dead namespace");
| < | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
* Review of those designs might permit stricter checking here.
*/
if (nsPtr->flags & NS_DEAD) {
Tcl_Panic("Trying to push call frame for dead namespace");
}
}
nsPtr->activationCount++;
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
* 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. */
{
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
* 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. */
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 | * Read and unset traces are established on ::errorCode. * *---------------------------------------------------------------------- */ static char * EstablishErrorCodeTraces( | | | | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
* Read and unset traces are established on ::errorCode.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorCodeTraces(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorCodeRead, NULL);
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorCodeTraces, NULL);
return NULL;
}
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | * None. * *---------------------------------------------------------------------- */ static char * ErrorCodeRead( | | | | | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorCodeRead(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
}
if (iPtr->errorCode) {
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 | * Read and unset traces are established on ::errorInfo. * *---------------------------------------------------------------------- */ static char * EstablishErrorInfoTraces( | | | | | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
* Read and unset traces are established on ::errorInfo.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorInfoTraces(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorInfoRead, NULL);
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorInfoTraces, NULL);
return NULL;
}
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 | * None. * *---------------------------------------------------------------------- */ static char * ErrorInfoRead( | | | | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorInfoRead(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
}
if (iPtr->errorInfo) {
|
| ︙ | ︙ | |||
781 782 783 784 785 786 787 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
| | | | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
nsPtr = (Namespace *)ckalloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
nsPtr->name = (char *)ckalloc(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);
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
| | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
nsPtr->fullName = (char *)ckalloc(nameLen + 1);
memcpy(nsPtr->fullName, name, nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
Tcl_DStringFree(&tmpBuffer);
/*
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
*
* 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;) {
| | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
*
* 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((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
} else {
entryPtr = Tcl_NextHashEntry(&search);
}
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 |
* 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) {
int length = nsPtr->cmdTable.numEntries;
| | | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 |
* 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) {
int length = nsPtr->cmdTable.numEntries;
Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
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((Tcl_Interp *) iPtr,
(Tcl_Command) cmds[i]);
TclCleanupCommandMacro(cmds[i]);
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
*
* Important: leave the hash table itself still live.
*/
#ifndef BREAK_NAMESPACE_COMPAT
while (nsPtr->childTable.numEntries > 0) {
int length = nsPtr->childTable.numEntries;
| | | | | 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 |
*
* Important: leave the hash table itself still live.
*/
#ifndef BREAK_NAMESPACE_COMPAT
while (nsPtr->childTable.numEntries > 0) {
int length = nsPtr->childTable.numEntries;
Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
children[i]->refCount++;
i++;
}
for (i = 0 ; i < length ; i++) {
Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
TclNsDecrRefCount(children[i]);
}
TclStackFree((Tcl_Interp *) iPtr, children);
}
#else
if (nsPtr->childTablePtr != NULL) {
while (nsPtr->childTablePtr->numEntries > 0) {
int length = nsPtr->childTablePtr->numEntries;
Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
children[i] = Tcl_GetHashValue(entryPtr);
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = (char *)ckalloc(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
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 |
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)) {
| | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
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;
}
}
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 | Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the current * namespace would create a cycle of imported command references. */ | | | | | > > | | | | 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 |
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", NULL);
return TCL_ERROR;
}
}
}
dataPtr = (ImportedCmdData *)ckalloc(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 *)ckalloc(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;
|
| ︙ | ︙ | |||
1898 1899 1900 1901 1902 1903 1904 |
/*
* The pattern is simple. Delete any imported commands that match it.
*/
if (TclMatchIsTrivial(simplePattern)) {
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (hPtr != NULL) {
| | | | | | | 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 |
/*
* 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) {
|
| ︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 |
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
| | | 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 |
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *)cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 |
InvokeImportedNRCmd(
ClientData 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. */
{
| | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
InvokeImportedNRCmd(
ClientData 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
|
| ︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 |
*/
static void
DeleteImportedCmd(
ClientData clientData) /* Points to the imported command's
* ImportedCmdData structure. */
{
| | > | 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 |
*/
static void
DeleteImportedCmd(
ClientData 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) {
if (refPtr->importedCmdPtr == selfPtr) {
/*
* Remove *refPtr from real command's list of imported commands
* that refer to it.
*/
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
TclCleanupCommandMacro(realCmdPtr);
ckfree(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 |
if (nsPtr->childTablePtr == NULL) {
entryPtr = NULL;
} else {
entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
}
#endif
if (entryPtr != NULL) {
| | | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 |
if (nsPtr->childTablePtr == NULL) {
entryPtr = NULL;
} else {
entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
}
#endif
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 *)
|
| ︙ | ︙ | |||
2385 2386 2387 2388 2389 2390 2391 |
if (altNsPtr->childTablePtr != NULL) {
entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
} else {
entryPtr = NULL;
}
#endif
if (entryPtr != NULL) {
| | | 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 |
if (altNsPtr->childTablePtr != NULL) {
entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
} else {
entryPtr = NULL;
}
#endif
if (entryPtr != NULL) {
altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
|
| ︙ | ︙ | |||
2635 2636 2637 2638 2639 2640 2641 |
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|| !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
| | | | | 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 |
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|| !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
/*
* Next, check along the path.
*/
for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; 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_DYING)) {
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_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
} else {
Namespace *nsPtr[2];
int search;
|
| ︙ | ︙ | |||
2696 2697 2698 2699 2700 2701 2702 |
*/
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
| | | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
*/
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;
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
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. */
| | | | 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 |
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
|
| ︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 |
hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
trailNsPtr->name);
} else {
hPtr = NULL;
}
#endif
if (hPtr != NULL) {
| | | 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 |
hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
trailNsPtr->name);
} else {
hPtr = NULL;
}
#endif
if (hPtr != NULL) {
shadowNsPtr = (Namespace *)Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
}
}
/*
|
| ︙ | ︙ | |||
2850 2851 2852 2853 2854 2855 2856 |
* the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
| | | 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 |
* 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);
}
|
| ︙ | ︙ | |||
2994 2995 2996 2997 2998 2999 3000 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceChildrenCmd( | | | 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceChildrenCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
|
| ︙ | ︙ | |||
3078 3079 3080 3081 3082 3083 3084 |
#else
if (nsPtr->childTablePtr == NULL) {
goto searchDone;
}
entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
while (entryPtr != NULL) {
| | | 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 |
#else
if (nsPtr->childTablePtr == NULL) {
goto searchDone;
}
entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
while (entryPtr != NULL) {
childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
|
| ︙ | ︙ | |||
3123 3124 3125 3126 3127 3128 3129 | * result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceCodeCmd( | | | 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 |
* result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCodeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
const char *arg;
|
| ︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceCurrentCmd( | | | 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCurrentCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
if (objc != 1) {
|
| ︙ | ︙ | |||
3267 3268 3269 3270 3271 3272 3273 | * function returns an error message in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd( | | | 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
* function returns an error message in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceDeleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
const char *name;
int i;
|
| ︙ | ︙ | |||
3355 3356 3357 3358 3359 3360 3361 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
objv);
}
static int
NRNamespaceEvalCmd(
| | | 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
objv);
}
static int
NRNamespaceEvalCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker;
int word;
|
| ︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 |
static int
NsEval_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 |
static int
NsEval_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0];
if (result == TCL_ERROR) {
int length = strlen(namespacePtr->fullName);
int 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 : length), namespacePtr->fullName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ | |||
3487 3488 3489 3490 3491 3492 3493 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExistsCmd( | | | 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
3542 3543 3544 3545 3546 3547 3548 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExportCmd( | | | > | | 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 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExportCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int firstArg, i;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
/*
* If no pattern arguments are given, and "-clear" isn't specified, return
* 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.
*/
|
| ︙ | ︙ | |||
3623 3624 3625 3626 3627 3628 3629 | * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceForgetCmd( | | | 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 |
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceForgetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *pattern;
int i, result;
|
| ︙ | ︙ | |||
3688 3689 3690 3691 3692 3693 3694 | * result object. * *---------------------------------------------------------------------- */ static int NamespaceImportCmd( | | | 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 |
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceImportCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowOverwrite = 0;
const char *string, *pattern;
int i, result;
|
| ︙ | ︙ | |||
3728 3729 3730 3731 3732 3733 3734 |
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)) {
| | | | 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 |
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 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
objv);
}
static int
NRNamespaceInscopeCmd(
| | | 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
objv);
}
static int
NRNamespaceInscopeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
int i;
|
| ︙ | ︙ | |||
3900 3901 3902 3903 3904 3905 3906 | * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceOriginCmd( | | | | | > > > > > > > > > > > < < < < < < < < < < < < < > | 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 |
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceOriginCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
cmd = Tcl_GetCommandFromObj(interp, objv[1]);
if (cmd == NULL) {
goto namespaceOriginError;
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) {
Tcl_DecrRefCount(resultPtr);
namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceParentCmd --
*
* Invoked to implement the "namespace parent" command that returns the
|
| ︙ | ︙ | |||
3961 3962 3963 3964 3965 3966 3967 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceParentCmd( | | | 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceParentCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *nsPtr;
if (objc == 1) {
|
| ︙ | ︙ | |||
4019 4020 4021 4022 4023 4024 4025 | * names that depend on the namespace for resolution). * *---------------------------------------------------------------------- */ static int NamespacePathCmd( | | | > | | 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 |
* names that depend on the namespace for resolution).
*
*----------------------------------------------------------------------
*/
static int
NamespacePathCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
int i, nsObjc, result = TCL_ERROR;
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
return TCL_ERROR;
}
/*
* If no path is given, return the current path.
*/
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, Tcl_NewStringObj(
nsPtr->commandPathArray[i].nsPtr->fullName, -1));
}
}
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;
}
|
| ︙ | ︙ | |||
4112 4113 4114 4115 4116 4117 4118 |
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
int pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
| | | 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 |
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
int pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
(NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength);
int i;
for (i=0 ; i<pathLength ; i++) {
tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
tmpPathArray[i].creatorNsPtr = nsPtr;
tmpPathArray[i].prevPtr = NULL;
tmpPathArray[i].nextPtr =
|
| ︙ | ︙ | |||
4244 4245 4246 4247 4248 4249 4250 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceQualifiersCmd( | | | 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceQualifiersCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *p;
int length;
|
| ︙ | ︙ | |||
4312 4313 4314 4315 4316 4317 4318 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceUnknownCmd( | | | 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceUnknownCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *currNsPtr;
Tcl_Obj *resultPtr;
int rc;
|
| ︙ | ︙ | |||
4499 4500 4501 4502 4503 4504 4505 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceTailCmd( | | | 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceTailCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *p;
if (objc != 2) {
|
| ︙ | ︙ | |||
4557 4558 4559 4560 4561 4562 4563 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceUpvarCmd( | | | 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceUpvarCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Namespace *nsPtr, *savedNsPtr;
Var *otherPtr, *arrayPtr;
|
| ︙ | ︙ | |||
4631 4632 4633 4634 4635 4636 4637 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceWhichCmd( | | | 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceWhichCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const opts[] = {
"-command", "-variable", NULL
};
|
| ︙ | ︙ | |||
4815 4816 4817 4818 4819 4820 4821 |
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
| | | 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 |
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 0;
|
| ︙ | ︙ | |||
4875 4876 4877 4878 4879 4880 4881 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
| | | 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
}
return nPtr->childTablePtr;
#endif
}
/*
|
| ︙ | ︙ | |||
4964 4965 4966 4967 4968 4969 4970 |
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
| | | 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 |
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) 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
|
| ︙ | ︙ | |||
5033 5034 5035 5036 5037 5038 5039 |
*/
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
| | | 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 |
*/
} else if (iPtr->varFramePtr != iPtr->framePtr) {
/*
* uplevel case, [lappend errorstack UP $relativelevel]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj(
iPtr->framePtr->level - iPtr->varFramePtr->level));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
/*
* normal case, [lappend errorstack CALL [info level 0]]
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
1 2 3 4 5 6 7 8 9 | /* * tclNotify.c -- * * This file implements the generic portion of the Tcl notifier. The * notifier is lowest-level part of the event system. It manages an event * queue that holds Tcl_Event structures. The platform specific portion * of the notifier is defined in the tcl*Notify.c files in each platform * directory. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclNotify.c -- * * This file implements the generic portion of the Tcl notifier. The * notifier is lowest-level part of the event system. It manages an event * queue that holds Tcl_Event structures. The platform specific portion * of the notifier is defined in the tcl*Notify.c files in each platform * directory. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * Copyright © 2003 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
1 2 3 4 5 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright © 2005-2012 Donal K. Fellows * Copyright © 2017 Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
73 74 75 76 77 78 79 | 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); static int InitFoundation(Tcl_Interp *interp); | | < | < < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | 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); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static Tcl_CommandTraceProc ObjectRenamedTrace; static inline void RemoveClass(Class **list, int num, int idx); static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
static const Tcl_MethodType classConstructor = {
TCL_OO_METHOD_VERSION_CURRENT,
"oo::class constructor",
TclOO_Class_Constructor, NULL, NULL
};
/*
| | > > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
static const Tcl_MethodType classConstructor = {
TCL_OO_METHOD_VERSION_CURRENT,
"oo::class constructor",
TclOO_Class_Constructor, NULL, NULL
};
/*
* Scripted parts of TclOO. First, the main script (cannot be outside this
* file).
*/
static const char *initScript =
#ifndef TCL_NO_DEPRECATED
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
#endif
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
* The scripted part of the definitions of TclOO.
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
* to be fully provided.
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
| > | | > > > | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
* to be fully provided.
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
#ifndef TCL_NO_DEPRECATED
Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
(void *) &tclOOStubs);
#endif
return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
(void *) &tclOOStubs);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetFoundation --
*
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
| | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
(ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation));
Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
/*
* Initialize the structure that holds the OO system core. This is
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
* ----------------------------------------------------------------------
*/
static void
DeletedDefineNamespace(
ClientData clientData)
{
| | | | < | | | | 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 |
* ----------------------------------------------------------------------
*/
static void
DeletedDefineNamespace(
ClientData clientData)
{
Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
static void
DeletedObjdefNamespace(
ClientData clientData)
{
Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
static void
DeletedHelpersNamespace(
ClientData 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);
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
int creationEpoch;
| | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
int creationEpoch;
oPtr = (Object *)ckalloc(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).
|
| ︙ | ︙ | |||
731 732 733 734 735 736 737 |
/*
* 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;
| | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
/*
* 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 *)ckalloc(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,
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 |
*/
static void
MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
| | | | | | | | 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 |
*/
static void
MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
static void
MyClassDeleted(
ClientData 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(
ClientData 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) {
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
*/
static void
ObjectNamespaceDeleted(
ClientData clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
| | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
*/
static void
ObjectNamespaceDeleted(
ClientData 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 = oPtr->fPtr->interp;
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 |
/*
* Instruct everyone to no longer use any allocated fields of the object.
* Also delete the command that refers to the object at this point (if it
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
| | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
/*
* Instruct everyone to no longer use any allocated fields of the object.
* Also delete the command that refers to the object at this point (if it
* still exists) because otherwise its pointer to the object points into
* freed memory.
*/
if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
*/
} else {
/*
* The namespace must have been deleted directly. Delete the command
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 |
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) {
| | | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 |
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 **)ckalloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list,
sizeof(Object *) * clsPtr->instances.size);
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
AddRef(oPtr);
}
|
| ︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
| | | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 |
{
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 **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1554 1555 1556 1557 1558 1559 1560 |
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
| | | | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
{
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 **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list,
sizeof(Class *) * superPtr->mixinSubs.size);
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1602 1603 1604 1605 1606 1607 1608 |
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);
| | | | 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 |
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 *)ckalloc(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 **)ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
*/
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 |
static int
FinalizeAlloc(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 |
static int
FinalizeAlloc(
ClientData 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)) {
|
| ︙ | ︙ | |||
2070 2071 2072 2073 2074 2075 2076 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
| | | | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = (Class **) ckrealloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list =
(Class **)ckalloc(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);
|
| ︙ | ︙ | |||
2368 2369 2370 2371 2372 2373 2374 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2448 2449 2450 2451 2452 2453 2454 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 |
static int
PublicNRObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | | 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 |
static int
PublicNRObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
NULL);
}
int
TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
}
static int
PrivateNRObjectCmd(
ClientData 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. */
|
| ︙ | ︙ | |||
2589 2590 2591 2592 2593 2594 2595 |
static int
MyClassNRObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 |
static int
MyClassNRObjCmd(
ClientData 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);
|
| ︙ | ︙ | |||
2648 2649 2650 2651 2652 2653 2654 |
/*
* Determine if we're in a context that can see the extra, private methods
* in this class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
| | | 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 |
/*
* 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) {
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 |
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeObjectCall(
ClientData data[],
| | | | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 |
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeObjectCall(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
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 --
|
| ︙ | ︙ | |||
2918 2919 2920 2921 2922 2923 2924 |
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeNext(
ClientData data[],
| | | | 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 |
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeNext(
ClientData 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]);
|
| ︙ | ︙ | |||
2962 2963 2964 2965 2966 2967 2968 |
}
if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
| | | 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 |
}
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),
NULL);
return NULL;
|
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 |
Object *oPtr)
{
Tcl_Obj *namePtr;
if (oPtr->cachedNameObj) {
return oPtr->cachedNameObj;
}
| | | 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
Object *oPtr)
{
Tcl_Obj *namePtr;
if (oPtr->cachedNameObj) {
return oPtr->cachedNameObj;
}
TclNewObj(namePtr);
Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
Tcl_IncrRefCount(namePtr);
oPtr->cachedNameObj = namePtr;
return namePtr;
}
Tcl_Obj *
|
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
1 2 3 4 5 6 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * * Copyright © 2005-2013 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
static int
FinalizeConstruction(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 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 |
static int
FinalizeConstruction(
ClientData 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;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Class_Constructor --
*
* Implementation for oo::class constructor.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Constructor(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj **invoke, *nameObj;
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
TclGetString(nameObj), NULL, -1, NULL, -1);
Tcl_DecrRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
| | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
TclGetString(nameObj), NULL, -1, NULL, -1);
Tcl_DecrRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
invoke = (Tcl_Obj **)ckalloc(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.
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
static int
DecrRefsPostClassConstructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
static int
DecrRefsPostClassConstructor(
ClientData 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] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 | * Implementation for oo::class->create method. * * ---------------------------------------------------------------------- */ int TclOO_Class_Create( | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 |
* Implementation for oo::class->create method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Create(
TCL_UNUSED(ClientData),
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. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | * Implementation for oo::class->createWithNamespace method. * * ---------------------------------------------------------------------- */ int TclOO_Class_CreateNs( | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
* Implementation for oo::class->createWithNamespace method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_CreateNs(
TCL_UNUSED(ClientData),
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. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 | * Implementation for oo::class->new method. * * ---------------------------------------------------------------------- */ int TclOO_Class_New( | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
* Implementation for oo::class->new method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_New(
TCL_UNUSED(ClientData),
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. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * Implementation for oo::object->destroy method. * * ---------------------------------------------------------------------- */ int TclOO_Object_Destroy( | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
* Implementation for oo::object->destroy method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Destroy(
TCL_UNUSED(ClientData),
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. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
static int
AfterNRDestructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 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 |
static int
AfterNRDestructor(
ClientData 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;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Object_Eval --
*
* Implementation for oo::object->eval method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Eval(
TCL_UNUSED(ClientData),
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. */
{
CallContext *contextPtr = (CallContext *) context;
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
static int
FinalizeEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
| | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
static int
FinalizeEval(
ClientData 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";
}
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 | * just creates a suitable error message. * * ---------------------------------------------------------------------- */ int TclOO_Object_Unknown( | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
* just creates a suitable error message.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Unknown(
TCL_UNUSED(ClientData),
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. */
{
CallContext *contextPtr = (CallContext *) context;
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
/*
* Determine if the calling context should know about extra private
* methods, and if so, which.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
| | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
/*
* 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;
}
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | * Implementation of oo::object->variable method. * * ---------------------------------------------------------------------- */ int TclOO_Object_LinkVar( | | | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
* Implementation of oo::object->variable method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_LinkVar(
TCL_UNUSED(ClientData),
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. */
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | * Implementation of the oo::object->varname method. * * ---------------------------------------------------------------------- */ int TclOO_Object_VarName( | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
* Implementation of the oo::object->varname method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_VarName(
TCL_UNUSED(ClientData),
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. */
{
Var *varPtr, *aryVar;
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
* 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 *) Tcl_ObjectContextObject(context);
| | | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
* 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 *) Tcl_ObjectContextObject(context);
CallContext *callerContext = (CallContext *)framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
int i;
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
}
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
| | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
}
/*
* 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, (Tcl_Var) aryVar, varNamePtr);
/*
* WARNING! This code pokes inside the implementation of hash tables!
*/
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 | * method. * * ---------------------------------------------------------------------- */ int TclOONextObjCmd( | | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
* method.
*
* ----------------------------------------------------------------------
*/
int
TclOONextObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Tcl_ObjectContext context;
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
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])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | | 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 |
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])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
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);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
int
TclOONextToObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Class *classPtr;
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
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])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
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])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
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...?");
|
| ︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 |
static int
NextRestoreFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 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 |
static int
NextRestoreFrame(
ClientData 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 = PTR2INT(data[2]);
}
return result;
}
/*
* ----------------------------------------------------------------------
*
* TclOOSelfObjCmd --
*
* Implementation of the [self] command, which provides introspection of
* the call context.
*
* ----------------------------------------------------------------------
*/
int
TclOOSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *const subcmds[] = {
"call", "caller", "class", "filter", "method", "namespace", "next",
"object", "target", NULL
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
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) {
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
| | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
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;
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 |
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
| | | | 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 |
result[0] = TclOOObjectName(interp, declarerPtr);
result[1] = mPtr->namePtr;
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
TclNewIntObj(result[1], contextPtr->index);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* CopyObjectCmd --
*
* Implementation of the [oo::copy] command, which clones an object (but
* not its namespace). Note that no constructors are called during this
* process.
*
* ----------------------------------------------------------------------
*/
int
TclOOCopyObjectCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 4) {
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
1 2 3 4 5 6 | /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. * * Copyright © 2005-2012 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr,
| | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr,
(CallChain *)TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
TclOODeleteChain(
(CallChain *)TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInvokeContext --
*
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
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. */
{
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
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 |
return mPtr->typePtr->callProc(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
ClientData data[],
| | | | | | | | 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 |
return mPtr->typePtr->callProc(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
static int
ResetFilterFlags(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeMethodRefs(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
int i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
}
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
/*
* 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.
*/
| | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
/*
* 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 **)ckalloc(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);
}
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
if (hPtr != NULL) {
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
donePrivate = 1;
}
}
}
return donePrivate;
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
if (hPtr != NULL) {
| | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) 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;
}
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
| | | 911 912 913 914 915 916 917 918 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, (char*) methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
}
}
}
}
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
* 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 =
| | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
* 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 =
(struct MInvoke *)ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
memcpy(callPtr->chain, callPtr->staticChain,
sizeof(struct MInvoke) * callPtr->numChain);
} else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
callPtr->chain = (struct MInvoke *)ckrealloc(callPtr->chain,
sizeof(struct MInvoke) * (callPtr->numChain + 1));
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
callPtr->chain[i].filterDeclarer = filterDecl;
callPtr->numChain++;
}
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 |
* the object, and in the class).
*/
const Tcl_ObjIntRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) {
| | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
* the object, and in the class).
*/
const Tcl_ObjIntRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) {
callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL);
}
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
(char *) methodNameObj);
} else {
hPtr = NULL;
}
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
| | | | 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 |
(char *) 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 *)ckalloc(sizeof(CallChain));
InitCallChain(callPtr, oPtr, flags);
cb.callChainPtr = callPtr;
cb.filterLength = 0;
cb.oPtr = oPtr;
/*
|
| ︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 |
return NULL;
}
} else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
| | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 |
return NULL;
}
} else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
(Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
(char *) methodNameObj, &i);
} else {
if (oPtr->chainCache == NULL) {
oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
(char *) methodNameObj, &i);
}
}
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
}
oPtr->selfCls->destructorChainPtr = callPtr;
callPtr->refCount++;
}
returnContext:
| | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
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);
|
| ︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
| | | | 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 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) 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 *)ckalloc(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;
|
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 |
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
if (clsPtr->classChainCache == NULL) {
| | | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
(char *) methodNameObj, &i);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
|
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 |
filterDecl)) {
return 1;
}
}
if (classPtr == contextCls) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
| | | | 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
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;
}
}
|
| ︙ | ︙ | |||
1737 1738 1739 1740 1741 1742 1743 |
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
| | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) 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;
}
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 |
* 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).
*/
| | | 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 |
* 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++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
|
| ︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 |
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
definePtr->list =
| | | | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 |
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
definePtr->list =
(DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size);
memcpy(definePtr->list, staticList,
sizeof(DefineEntry) * definePtr->num);
} else {
definePtr->list = (DefineEntry *)ckrealloc(definePtr->list,
sizeof(DefineEntry) * definePtr->size);
}
}
definePtr->list[i].definerCls = definerCls;
definePtr->list[i].namespaceName = namespaceName;
definePtr->num++;
}
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
1 2 3 4 5 6 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * * Copyright © 2006-2013 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
| | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
filtersList = (Tcl_Obj **)ckalloc(size);
} else {
filtersList = (Tcl_Obj **)ckrealloc(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;
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
| | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
filtersList = (Tcl_Obj **)ckalloc(size);
} else {
filtersList = (Tcl_Obj **)ckrealloc(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;
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
oPtr->mixins.list = (Class **)ckalloc(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);
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
}
} else {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
}
} else {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
/*
|
| ︙ | ︙ | |||
498 499 500 501 502 503 504 |
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(vnlPtr->list);
} else if (i) {
| | | | | 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 |
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(vnlPtr->list);
} else if (i) {
vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
} else {
vnlPtr->list = (Tcl_Obj **)ckalloc(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 **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
static inline void
InstallPrivateVariableMapping(
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(pvlPtr->list);
} else if (i) {
| | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(pvlPtr->list);
} else if (i) {
pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * varc);
} else {
pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc);
}
}
pvlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
pvlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
| | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 |
pvlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
|
| ︙ | ︙ | |||
660 661 662 663 664 665 666 |
}
}
/*
* Complete the splicing by changing the method's name.
*/
| | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
}
}
/*
* 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) {
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 | * prefix of. * * ---------------------------------------------------------------------- */ int TclOOUnknownDefinition( | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
* prefix of.
*
* ----------------------------------------------------------------------
*/
int
TclOOUnknownDefinition(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
| | | | 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 |
soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
goto noMatch;
}
matchedStr = nameStr;
}
hPtr = Tcl_NextHashEntry(&search);
}
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, -1);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
&& 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", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
| | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 |
&& 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", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
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", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
|
| ︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 |
isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv);
/*
* Build the list of arguments using a Tcl_Obj as a workspace. See
* comments above for why these contortions are necessary.
*/
| | | | 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 |
isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv);
/*
* Build the list of arguments using a Tcl_Obj as a workspace. See
* comments above for why these contortions are necessary.
*/
TclNewObj(objPtr);
TclNewObj(obj2Ptr);
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
/*
* Punt this case!
*/
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
|
| ︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineObjCmd( | | | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOOObjDefObjCmd( | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOOObjDefObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 | * dispatch so that error messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineSelfObjCmd( | | | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
* dispatch so that error messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result, isPrivate;
|
| ︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineObjSelfObjCmd( | | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
if (objc != 1) {
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineClassObjCmd( | | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineClassObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Foundation *fPtr = TclOOGetFoundation(interp);
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineConstructorObjCmd( | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineConstructorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
|
| ︙ | ︙ | |||
1589 1590 1591 1592 1593 1594 1595 | * "oo::define" command. * * ---------------------------------------------------------------------- */ int TclOODefineDefnNsObjCmd( | | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
* "oo::define" command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDefnNsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *kindList[] = {
"-class",
"-instance",
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineDestructorObjCmd( | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDestructorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
* 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) {
| | | | | 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 |
* 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 *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)ckalloc(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;
}
}
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
* 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) {
| | | | | 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 |
* 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 *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)ckalloc(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;
}
}
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | * command. * * ---------------------------------------------------------------------- */ static int ClassFilterGet( | | | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassFilterGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
|
| ︙ | ︙ | |||
2334 2335 2336 2337 2338 2339 2340 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | 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 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, oPtr->classPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilterSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 | * command. * * ---------------------------------------------------------------------- */ static int ClassMixinGet( | | | 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassMixinGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2415 2416 2417 2418 2419 2420 2421 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | 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 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, oPtr->classPtr->mixins) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixinSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i, isNew;
|
| ︙ | ︙ | |||
2462 2463 2464 2465 2466 2467 2468 |
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
| | | 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 |
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = (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--;
|
| ︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 | * command. * * ---------------------------------------------------------------------- */ static int ClassSuperGet( | | | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassSuperGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | 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 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(superPtr, oPtr->classPtr->superclasses) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, superPtr->thisPtr));
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuperSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int superc, i, j;
|
| ︙ | ︙ | |||
2596 2597 2598 2599 2600 2601 2602 |
* 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) {
| | | 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 |
* 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 **)ckrealloc(superclasses, sizeof(Class *));
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
} else {
superclasses[0] = oPtr->fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
|
| ︙ | ︙ | |||
2678 2679 2680 2681 2682 2683 2684 | * command. * * ---------------------------------------------------------------------- */ static int ClassVarsGet( | | | 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassVarsGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
| | | | 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 |
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
if (IsPrivateDefine(interp)) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
FOREACH(variableObj, oPtr->classPtr->variables) {
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVarsSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 | * command. * * ---------------------------------------------------------------------- */ static int ObjFilterGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjFilterGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, oPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjFilterSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
|
| ︙ | ︙ | |||
2861 2862 2863 2864 2865 2866 2867 | * command. * * ---------------------------------------------------------------------- */ static int ObjMixinGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjMixinGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
Class *mixinPtr;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjMixinSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i, isNew;
|
| ︙ | ︙ | |||
2922 2923 2924 2925 2926 2927 2928 |
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
| | | 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 |
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(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;
|
| ︙ | ︙ | |||
2963 2964 2965 2966 2967 2968 2969 | * command. * * ---------------------------------------------------------------------- */ static int ObjVarsGet( | | | | | 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 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjVarsGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
if (IsPrivateDefine(interp)) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
FOREACH(variableObj, oPtr->variables) {
Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVarsSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
|
| ︙ | ︙ | |||
3066 3067 3068 3069 3070 3071 3072 | * names to their fully-qualified names if possible. * * ---------------------------------------------------------------------- */ static int ResolveClass( | | | 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 |
* names to their fully-qualified names if possible.
*
* ----------------------------------------------------------------------
*/
static int
ResolveClass(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
int idx = Tcl_ObjectContextSkippedArgs(context);
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
1 2 3 4 5 6 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. * * Copyright © 2006-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
| | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
* Build the ensembles used to implement [info object] and [info class].
*/
TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the [info] ensemble.
*/
infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (infoCmd) {
Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1),
Tcl_NewStringObj("::oo::InfoObject", -1));
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | * Implements [info object class $objName ?$className?] * * ---------------------------------------------------------------------- */ static int InfoObjectClassCmd( | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
* Implements [info object class $objName ?$className?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectClassCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2 && objc != 3) {
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
}
FOREACH(mixinPtr, oPtr->mixins) {
if (!mixinPtr) {
continue;
}
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
| | | | | 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 |
}
FOREACH(mixinPtr, oPtr->mixins) {
if (!mixinPtr) {
continue;
}
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
return TCL_OK;
}
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectDefnCmd --
*
* Implements [info object definition $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectDefnCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Proc *procPtr;
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | | | | | | | 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 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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,
Tcl_NewStringObj(localPtr->name, -1));
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;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectFiltersCmd --
*
* Implements [info object filters $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Object *oPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, oPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectForwardCmd --
*
* Implements [info object forward $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectForwardCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * Implements [info object isa $category $objName ...] * * ---------------------------------------------------------------------- */ static int InfoObjectIsACmd( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* Implements [info object isa $category $objName ...]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIsACmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const categories[] = {
"class", "metaclass", "mixin", "object", "typeof", NULL
};
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 | * Implements [info object methods $objName ?$option ...?] * * ---------------------------------------------------------------------- */ static int InfoObjectMethodsCmd( | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* Implements [info object methods $objName ?$option ...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
break;
case SCOPE_UNEXPORTED:
flag = 0;
break;
}
}
| | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
break;
case SCOPE_UNEXPORTED:
flag = 0;
break;
}
}
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,
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 | * Implements [info object methodtype $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectMethodTypeCmd( | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
* Implements [info object methodtype $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMethodTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Method *mPtr;
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | * Implements [info object mixins $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectMixinsCmd( | | | | 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 |
* Implements [info object mixins $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMixinsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *mixinPtr;
Object *oPtr;
Tcl_Obj *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, oPtr->mixins) {
if (!mixinPtr) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | * Implements [info object creationid $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectIdCmd( | | | | | 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 |
* Implements [info object creationid $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIdCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "objName");
return TCL_ERROR;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectNsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 | * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoObjectVariablesCmd( | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 |
* Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
isPrivate = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
| | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
isPrivate = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
if (isPrivate) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 | * Implements [info object vars $objName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoObjectVarsCmd( | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
* Implements [info object vars $objName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVarsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
const char *pattern = NULL;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
| | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
TclNewObj(resultObj);
/*
* Extract the information we need from the object's namespace's table of
* variables. Note that this involves horrific knowledge of the guts of
* tclVar.c, so we can't leverage our hash-iteration macros properly.
*/
|
| ︙ | ︙ | |||
913 914 915 916 917 918 919 | * Implements [info class constructor $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassConstrCmd( | | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
* Implements [info class constructor $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassConstrCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *resultObjs[2];
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
return TCL_ERROR;
}
| | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", 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,
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 | * Implements [info class definition $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassDefnCmd( | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
* Implements [info class definition $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Proc *procPtr;
CompiledLocal *localPtr;
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | | | | | 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 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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,
Tcl_NewStringObj(localPtr->name, -1));
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;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassDefnNsCmd --
*
* Implements [info class definitionnamespace $clsName ?$kind?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnNsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *kindList[] = {
"-class",
"-instance",
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | * Implements [info class destructor $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassDestrCmd( | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
* Implements [info class destructor $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDestrCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Proc *procPtr;
Class *clsPtr;
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | * Implements [info class filters $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassFiltersCmd( | | | | | 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 |
* Implements [info class filters $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassFiltersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(filterObj, clsPtr->filters) {
Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassForwardCmd --
*
* Implements [info class forward $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassForwardCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
Class *clsPtr;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), 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",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * Implements [info class instances $clsName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoClassInstancesCmd( | | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
* Implements [info class instances $clsName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassInstancesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Class *clsPtr;
int i;
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
| | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
TclNewObj(resultObj);
FOREACH(oPtr, clsPtr->instances) {
Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 | * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ static int InfoClassMethodsCmd( | | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
* Implements [info class methods $clsName ?options...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
|
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 |
break;
case SCOPE_UNEXPORTED:
flag = 0;
break;
}
}
| | | 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 |
break;
case SCOPE_UNEXPORTED:
flag = 0;
break;
}
}
TclNewObj(resultObj);
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 | * Implements [info class methodtype $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassMethodTypeCmd( | | | 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 |
* Implements [info class methodtype $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodTypeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Method *mPtr;
Class *clsPtr;
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * Implements [info class mixins $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassMixinsCmd( | | | | 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 |
* Implements [info class mixins $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMixinsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *mixinPtr;
Tcl_Obj *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
FOREACH(mixinPtr, clsPtr->mixins) {
if (!mixinPtr) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 | * Implements [info class subclasses $clsName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoClassSubsCmd( | | | 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 |
* Implements [info class subclasses $clsName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassSubsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *subclassPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
1505 1506 1507 1508 1509 1510 1511 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
| | | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
if (clsPtr == NULL) {
return TCL_ERROR;
}
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
TclNewObj(resultObj);
FOREACH(subclassPtr, clsPtr->subclasses) {
Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
|
| ︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | * Implements [info class superclasses $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassSupersCmd( | | | | | 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 |
* Implements [info class superclasses $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassSupersCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *superPtr;
Tcl_Obj *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == 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;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassVariablesCmd --
*
* Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 |
isPrivate = 1;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
| | | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 |
isPrivate = 1;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
if (isPrivate) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
|
| ︙ | ︙ | |||
1631 1632 1633 1634 1635 1636 1637 | * Implements [info object call $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectCallCmd( | | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
* Implements [info object call $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectCallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
CallContext *contextPtr;
|
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | * Implements [info class call $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassCallCmd( | | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
* Implements [info class call $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassCallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
CallChain *callPtr;
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
* 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.
*/
typedef struct ThreadLocalData {
| | | | 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 |
* 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.
*/
typedef struct ThreadLocalData {
int 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;
typedef struct Foundation {
Tcl_Interp *interp;
Class *objectCls; /* The root of the object system. */
Class *classCls; /* The class of all classes. */
Tcl_Namespace *ooNs; /* ::oo namespace. */
Tcl_Namespace *defineNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::define" command acts as a special kind
* of ensemble for this namespace. */
Tcl_Namespace *objdefNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::objdefine" command acts as a special
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
* 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 ? \
| | | | | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
* 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_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 */
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
1 2 3 4 5 | /* * tclOOMethod.c -- * * This file contains code to create and manage methods. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclOOMethod.c -- * * This file contains code to create and manage methods. * * Copyright © 2005-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); | | < | < | < | < < | < < < | 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 |
CallContext *contextPtr, ProcedureMethod *pmPtr,
int objc, Tcl_Obj *const *objv,
PMFrameData *fdPtr);
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);
static Tcl_ResolveVarProc ProcedureMethodVarResolver;
static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
/*
* The types of methods defined by the core OO system.
*/
static const Tcl_MethodType procMethodType = {
TCL_OO_METHOD_VERSION_CURRENT, "method",
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 | * Attach a method to an object instance. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewInstanceMethod( | | | | | | | | 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 |
* Attach a method to an object instance.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Tcl_NewInstanceMethod(
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_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. */
{
Object *oPtr = (Object *) object;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
if (isNew) {
mPtr = (Method *)ckalloc(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;
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | * Attach a method to a class. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewMethod( | | | | | | | 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 |
* Attach a method to a class.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Tcl_NewMethod(
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_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 *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
if (isNew) {
mPtr = (Method *)ckalloc(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++;
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
int argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
| | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
int argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
int argsLen; /* -1 => delete argsObj before exit */
ProcedureMethod *pmPtr;
const char *procName;
Tcl_Method method;
if (argsObj == NULL) {
argsLen = -1;
| | | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
int argsLen; /* -1 => delete argsObj before exit */
ProcedureMethod *pmPtr;
const char *procName;
Tcl_Method method;
if (argsObj == NULL) {
argsLen = -1;
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
} else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
| | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
| | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
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. */
{
| | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
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
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 |
Tcl_ObjectContextSkippedArgs(context));
}
/*
* Allocate the special frame data.
*/
| | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
Tcl_ObjectContextSkippedArgs(context));
}
/*
* 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);
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
static int
FinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
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) {
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
}
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);
|
| ︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 |
* 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;
}
| | | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
* 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) {
|
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
}
Tcl_DecrRefCount(infoPtr->variableObj);
ckfree(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
| | | | | 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 |
}
Tcl_DecrRefCount(infoPtr->variableObj);
ckfree(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *varName,
int length,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
/*
* Do not create resolvers for cases that contain namespace separators or
* which look like array accesses. Both will lead us astray.
*/
if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
Tcl_DecrRefCount(variableObj);
return TCL_CONTINUE;
}
infoPtr = (OOResVarInfo *)ckalloc(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;
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 |
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
| | | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
struct PNI *pni = (struct PNI *)clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
if (object == NULL) {
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
}
return TclOOObjectName(pni->interp, (Object *) object);
}
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
* 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.
*
* ----------------------------------------------------------------------
*/
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
static void
MethodErrorHandler(
Tcl_Interp *interp,
| > > | > | | 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 |
* 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 : (len)), (str), ((len) > LIMIT ? "..." : "")
static void
MethodErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* We pull the method name out of context instead of from argument */
{
int nameLen, objectNameLen;
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
TclGetStringFromObj(mPtr->namePtr, &nameLen);
Object *declarerPtr;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
kindName, ELLIPSIFY(objectName, objectNameLen),
ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
}
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
| | > | | 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
kindName, ELLIPSIFY(objectName, objectNameLen),
ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
}
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* Ignore. We know it is the constructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
|
| ︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 |
"\n (%s \"%.*s%s\" constructor line %d)", kindName,
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}
static void
DestructorErrorHandler(
Tcl_Interp *interp,
| | > | | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
"\n (%s \"%.*s%s\" constructor line %d)", kindName,
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}
static void
DestructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* Ignore. We know it is the destructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
|
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 |
ckfree(pmPtr);
}
static void
DeleteProcedureMethod(
void *clientData)
{
| | | | | > | 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 |
ckfree(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, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, argsObj, argObj);
}
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
| | | 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
Tcl_IncrRefCount(argsObj);
Tcl_IncrRefCount(bodyObj);
if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
&pm2Ptr->procPtr) != TCL_OK) {
Tcl_DecrRefCount(argsObj);
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 |
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
| | | 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 |
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1436 1437 1438 1439 1440 1441 1442 |
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
| | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 |
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 |
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;
| | | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
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;
int numPrefixes, len, skip = contextPtr->skip;
/*
* 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
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 |
static int
FinalizeForwardCall(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | 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 |
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);
ckfree(fmPtr);
}
static int
CloneForwardMethod(
TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1551 1552 1553 1554 1555 1556 1557 |
*/
Proc *
TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
| | | | | 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 |
*/
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;
}
/*
|
| ︙ | ︙ | |||
1618 1619 1620 1621 1622 1623 1624 |
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. */
{
unsigned len = rewriteLength + objc - toRewrite;
| | | 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
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. */
{
unsigned 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
|
| ︙ | ︙ |
Changes to generic/tclOOStubLib.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
MODULE_SCOPE const char *
TclOOInitializeStubs(
Tcl_Interp *interp,
const char *version)
{
int exact = 0;
| | > > > > | > | 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 |
MODULE_SCOPE const char *
TclOOInitializeStubs(
Tcl_Interp *interp,
const char *version)
{
int exact = 0;
const char *packageName = "tcl::oo";
const char *errMsg = NULL;
TclOOStubs *stubsPtr = NULL;
const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
packageName = "TclOO";
actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
} else {
tclOOStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs;
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
1 2 3 4 5 6 | /* * tclObj.c -- * * This file contains Tcl object-related functions that are used by many * Tcl commands. * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclObj.c -- * * This file contains Tcl object-related functions that are used by many * Tcl commands. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * Copyright © 2001 ActiveState Corporation. * Copyright © 2005 Kevin B. Kenny. All rights reserved. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * * 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" |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 | * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) | | | | | | | | | | | | | | | 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 |
* These are separated out so that some semantic content is attached
* to them.
*/
#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++)
#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--)
#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr,objPtr) \
/* The string rep is already invalidated so we can use the bytes value \
* for our pointer chain: push onto the head of the stack. */ \
(objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr,objPtrVar) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#elif defined(HAVE_FAST_TSD)
static __thread PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
(PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
* 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 *)ckalloc(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 = (void *)(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);
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
/*
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
| | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
int num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1) *sizeof(int));
if (!newEntry) {
/*
* We're entering ContLineLoc data for the same value more than one
* time. Taking care not to leak the old entry.
*
* This can happen when literals in a proc body are shared. See for
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
| | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
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);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
| | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclThreadFinalizeContLines --
*
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 | * * TIP #280 *---------------------------------------------------------------------- */ static void TclThreadFinalizeContLines( | | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
TclThreadFinalizeContLines(
TCL_UNUSED(ClientData))
{
/*
* Release the hashtable tracking invisible continuation lines.
*/
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 | } /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * | | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 | } /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * * This function is called to register a new Tcl object type in the table * of all object types supported by Tcl. * * Results: * None. * * Side effects: * The type is registered in the Tcl type table. If there was already a |
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
* that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
| | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
* that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
{
Tcl_HashEntry *hPtr;
const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
| | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
{
Tcl_HashEntry *hPtr;
const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 995 996 997 998 |
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
void
TclDbDumpActiveObjects(
FILE *outFile)
{
| > < | > | > > > > > | 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 |
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
void
TclDbDumpActiveObjects(
FILE *outFile)
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
objData->file, objData->line);
} else {
fprintf(outFile, "key = 0x%p\n",
Tcl_GetHashKey(tablePtr, hPtr));
}
}
}
}
#else
void
TclDbDumpActiveObjects(
TCL_UNUSED(FILE *))
{
}
#endif
/*
*----------------------------------------------------------------------
*
* TclDbInitNewObj --
*
* Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 |
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
| | | | 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 |
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
/*
* Record the debugging information.
*/
objData = (ObjData *)ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
Tcl_SetHashValue(hPtr, objData);
}
#endif /* TCL_THREADS */
}
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(
| | < | < | 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 |
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
* freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
* but leaves it to Tcl's memory subsystem finalization to release it.
* Purify apparently can't figure that out, and fires a false alarm.
*/
| | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
* freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
* but leaves it to Tcl's memory subsystem finalization to release it.
* Purify apparently can't figure that out, and fires a false alarm.
*/
basePtr = (char *)ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
| | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
|
| ︙ | ︙ | |||
1765 1766 1767 1768 1769 1770 1771 |
}
/* Allocate */
if (objPtr->bytes == NULL) {
/* Allocate only as empty - extend later if bytes copied */
objPtr->length = 0;
if (numBytes) {
| | | | 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 |
}
/* Allocate */
if (objPtr->bytes == NULL) {
/* Allocate only as empty - extend later if bytes copied */
objPtr->length = 0;
if (numBytes) {
objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
if (objPtr->bytes == NULL) {
return NULL;
}
if (bytes) {
/* Copy */
memcpy(objPtr->bytes, bytes, numBytes);
objPtr->length = (int) numBytes;
}
} else {
TclInitStringRep(objPtr, NULL, 0);
}
} else {
/* objPtr->bytes != NULL bytes == NULL - Truncate */
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes + 1);
objPtr->length = (int)numBytes;
}
/* Terminate */
objPtr->bytes[objPtr->length] = '\0';
return objPtr->bytes;
|
| ︙ | ︙ | |||
2026 2027 2028 2029 2030 2031 2032 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
| | < | < | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
| | < | < | 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2897 2898 2899 2900 2901 2902 2903 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
| | < | < | 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
/*
|
| ︙ | ︙ | |||
3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 |
/*
* 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.
*/
mp_int big;
unsigned long scratch, value = 0;
unsigned char *bytes = (unsigned char *) &scratch;
size_t numBytes;
TclUnpackBignum(objPtr, big);
if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
| > | 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 |
/*
* 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.
*/
{
mp_int big;
unsigned long scratch, value = 0;
unsigned char *bytes = (unsigned char *) &scratch;
size_t numBytes;
TclUnpackBignum(objPtr, big);
if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
|
| ︙ | ︙ | |||
3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
}
} else {
if (value <= (unsigned long)ULONG_MAX) {
*longPtr = (long) value;
return TCL_OK;
}
}
}
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
| > | 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
}
} else {
if (value <= (unsigned long)ULONG_MAX) {
*longPtr = (long) value;
return TCL_OK;
}
}
}
}
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
|
| ︙ | ︙ | |||
3161 3162 3163 3164 3165 3166 3167 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
| | < | < | 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3543 3544 3545 3546 3547 3548 3549 |
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
void *bignumValue,
| | | | 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 |
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
void *bignumValue,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBignumObj(bignumValue);
}
#endif
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3830 3831 3832 3833 3834 3835 3836 |
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
| | | | 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &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;
}
} while (TCL_OK ==
|
| ︙ | ︙ | |||
3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
| > < | 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("incrementing refCount of previously disposed object");
}
#if TCL_THREADS
|
| ︙ | ︙ | |||
3967 3968 3969 3970 3971 3972 3973 |
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 */
| > > | > > > > > > > > | 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 |
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
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
++(objPtr)->refCount;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbDecrRefCount --
*
* This function is normally called when debugging: i.e., when
|
| ︙ | ︙ | |||
3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
| > < | 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("decrementing refCount of previously disposed object");
}
#if TCL_THREADS
|
| ︙ | ︙ | |||
4030 4031 4032 4033 4034 4035 4036 |
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 */
| > > > > > | > > > > > > | > | 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 |
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);
}
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbIsShared --
*
* This function is normally called when debugging: i.e., when
|
| ︙ | ︙ | |||
4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 |
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("checking whether previously disposed object is shared");
}
| > > > > > | 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 |
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
#ifdef TCL_MEM_DEBUG
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
#else
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
#endif
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("checking whether previously disposed object is shared");
}
|
| ︙ | ︙ | |||
4158 4159 4160 4161 4162 4163 4164 | * Increments the reference count on the object. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocObjEntry( | | | | | 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 |
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocObjEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
return hPtr;
}
|
| ︙ | ︙ | |||
4193 4194 4195 4196 4197 4198 4199 |
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
| | | 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 |
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
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
|
| ︙ | ︙ | |||
4279 4280 4281 4282 4283 4284 4285 | * None. * *---------------------------------------------------------------------- */ TCL_HASH_TYPE TclHashObjKey( | | | | | 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 |
* None.
*
*----------------------------------------------------------------------
*/
TCL_HASH_TYPE
TclHashObjKey(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
int length;
const char *string = TclGetStringFromObj(objPtr, &length);
TCL_HASH_TYPE result = 0;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
* following reasons:
|
| ︙ | ︙ | |||
4327 4328 4329 4330 4331 4332 4333 |
if (length > 0) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
}
}
| | | 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 |
if (length > 0) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFromObj --
*
|
| ︙ | ︙ | |||
4380 4381 4382 4383 4384 4385 4386 |
* Check also that the command's epoch is up to date, and that the command
* 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.
*/
| | | 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 |
* Check also that the command's epoch is up to date, and that the command
* 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 (objPtr->typePtr == &tclCmdNameType) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
|
| ︙ | ︙ | |||
4408 4409 4410 4411 4412 4413 4414 |
* 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;
}
| | | 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 |
* 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);
}
/*
*----------------------------------------------------------------------
*
* TclSetCmdNameObj --
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
| | | 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
fillPtr->refCount = 1;
}
fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
|
| ︙ | ︙ | |||
4497 4498 4499 4500 4501 4502 4503 |
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
if (objPtr->typePtr == &tclCmdNameType) {
| | | 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 |
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
if (objPtr->typePtr == &tclCmdNameType) {
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
return;
}
}
SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
|
| ︙ | ︙ | |||
4532 4533 4534 4535 4536 4537 4538 |
*/
static void
FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
| | | 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 |
*/
static void
FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
if (resPtr->refCount-- <= 1) {
|
| ︙ | ︙ | |||
4579 4580 4581 4582 4583 4584 4585 |
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | | 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 |
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
resPtr->refCount++;
copyPtr->typePtr = &tclCmdNameType;
}
|
| ︙ | ︙ | |||
4638 4639 4640 4641 4642 4643 4644 |
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Stop shimmering and caching nothing when we found nothing. Just
* report the failure to find the command as an error.
*/
| | | | 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 |
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
* Stop shimmering and caching nothing when we found nothing. Just
* report the failure to find the command as an error.
*/
if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
return TCL_ERROR;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
/*
* Re-use existing ResolvedCmdName struct when possible.
* Cleanup the old fields that need it.
*/
Command *oldCmdPtr = resPtr->cmdPtr;
|
| ︙ | ︙ | |||
4680 4681 4682 4683 4684 4685 4686 | * None. * *---------------------------------------------------------------------- */ int Tcl_RepresentationCmd( | | | 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_RepresentationCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *descObj;
if (objc != 2) {
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
1 2 3 4 5 | /* * tclOptimize.c -- * * This file contains the bytecode optimizer. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclOptimize.c -- * * This file contains the bytecode optimizer. * * Copyright © 2013 Donal Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
(tclInstructionTable[UCHAR(instruction)].numBytes)
/*
* ----------------------------------------------------------------------
*
* LocateTargetAddresses --
*
* Populate a hash table with places that we need to be careful around
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
* ----------------------------------------------------------------------
*/
void
TclOptimizeBytecode(
void *envPtr)
{
| | | | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
* ----------------------------------------------------------------------
*/
void
TclOptimizeBytecode(
void *envPtr)
{
ConvertZeroEffectToNOP((CompileEnv *)envPtr);
AdvanceJumps((CompileEnv *)envPtr);
TrimUnreachable((CompileEnv *)envPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclPanic.c.
1 2 3 4 5 6 7 | /* * tclPanic.c -- * * Source code for the "Tcl_Panic" library procedure for Tcl; individual * applications will probably call Tcl_SetPanicProc() to set an * application-specific panic procedure. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclPanic.c -- * * Source code for the "Tcl_Panic" library procedure for Tcl; individual * applications will probably call Tcl_SetPanicProc() to set an * application-specific panic procedure. * * Copyright © 1988-1993 The Regents of the University of California. * Copyright © 1994 Sun Microsystems, Inc. * 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" #if defined(_WIN32) || defined(__CYGWIN__) |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
void
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
void
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
if (((Tcl_PanicProc *)proc != tclWinDebugPanic) || (panicProc == NULL))
#elif defined(__CYGWIN__)
if (proc == NULL)
panicProc = tclWinDebugPanic;
else
#endif
panicProc = proc;
Tcl_InitSubsystems();
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ | < < | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ /* * The following comment is here so that Coverity's static analizer knows that * a Tcl_Panic() call can never return and avoids lots of false positives. */ /* coverity[+kill] */ void |
| ︙ | ︙ |
Changes to generic/tclParse.c.
1 2 3 4 5 6 7 | /* * tclParse.c -- * * This file contains functions that parse Tcl scripts. They do so in a * general-purpose fashion that can be used for many different purposes, * including compilation, direct execution, code analysis, etc. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclParse.c -- * * This file contains functions that parse Tcl scripts. They do so in a * general-purpose fashion that can be used for many different purposes, * including compilation, direct execution, code analysis, etc. * * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (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. */ #include "tclInt.h" |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
| | > > | 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 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
static int CommandComplete(const char *script, int numBytes);
static int ParseComment(const char *src, int numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, int numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static int ParseWhiteSpace(const char *src, int numBytes,
int *incompletePtr, char *typePtr);
static int ParseAllWhiteSpace(const char *src, int numBytes,
int *incompletePtr);
static int ParseHex(const char *src, int numBytes,
int *resultPtr);
/*
*----------------------------------------------------------------------
*
* TclParseInit --
*
* Initialize the fields of a Tcl_Parse struct.
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
| > > > > < < < < | 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 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
TclParseInit(interp, start, numBytes, parsePtr);
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
int dummy;
return ParseAllWhiteSpace(src, numBytes, &dummy);
}
/*
*----------------------------------------------------------------------
*
| | | | | 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 |
int dummy;
return ParseAllWhiteSpace(src, numBytes, &dummy);
}
/*
*----------------------------------------------------------------------
*
* ParseHex --
*
* Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing
* \x and \u escape sequences). At most numBytes bytes are scanned.
*
* Results:
* The numeric value is stored in *resultPtr. Returns the number of bytes
* consumed.
*
* Notes:
* Relies on the following properties of the ASCII character set, with
* which UTF-8 is compatible:
*
* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy
* consecutive code points, and '0' < 'A' < 'a'.
*
*----------------------------------------------------------------------
*/
int
ParseHex(
const char *src, /* First character to parse. */
int numBytes, /* Max number of byes to scan */
int *resultPtr) /* Points to storage provided by caller where
* the character resulting from the
* conversion is to be written. */
{
int result = 0;
const char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
if (!isxdigit(digit) || (result > 0x10FFF)) {
break;
}
p++;
result <<= 4;
if (digit >= 'a') {
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
int *readPtr, /* NULL, or points to storage where the number
* of bytes scanned should be written. */
char *dst) /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
* written. At most 4 bytes will be written there. */
{
const char *p = src+1;
| | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
int *readPtr, /* NULL, or points to storage where the number
* of bytes scanned should be written. */
char *dst) /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
* written. At most 4 bytes will be written there. */
{
const char *p = src+1;
int unichar;
int result;
int count;
char buf[4] = "";
if (numBytes == 0) {
if (readPtr != NULL) {
*readPtr = 0;
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
case 't':
result = 0x9;
break;
case 'v':
result = 0xB;
break;
case 'x':
| | | | | | | | | 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 |
case 't':
result = 0x9;
break;
case 'v':
result = 0xB;
break;
case 'x':
count += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "x".
*/
result = 'x';
} else {
/*
* Keep only the last byte (2 hex digits).
*/
result = UCHAR(result);
}
break;
case 'u':
count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
}
break;
case 'U':
count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
} else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
|
| ︙ | ︙ | |||
929 930 931 932 933 934 935 | /* * 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 */ | | | | | | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
/*
* 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 (TclUCS4Complete(p, numBytes - 1)) {
count = TclUtfToUCS4(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
count = TclUtfToUCS4(utfBytes, &unichar) + 1;
}
result = unichar;
break;
}
done:
if (readPtr != NULL) {
|
| ︙ | ︙ | |||
1139 1140 1141 1142 1143 1144 1145 | * Command substitution. Call Tcl_ParseCommand recursively (and * repeatedly) to parse the nested command(s), then throw away the * parse information. */ src++; numBytes--; | | | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
* Command substitution. Call Tcl_ParseCommand recursively (and
* repeatedly) to parse the nested command(s), then throw away the
* parse information.
*/
src++;
numBytes--;
nestedPtr = (Tcl_Parse *)TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
const char *curEnd;
if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
nestedPtr) != TCL_OK) {
parsePtr->errorType = nestedPtr->errorType;
parsePtr->term = nestedPtr->term;
|
| ︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 |
* reinitialize it. */
{
Tcl_Token *tokenPtr;
const char *src;
int varIndex;
unsigned array;
| < < < | < > > > | 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
* reinitialize it. */
{
Tcl_Token *tokenPtr;
const char *src;
int varIndex;
unsigned array;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
/*
* Generate one token for the variable, an additional token for the name,
* plus any number of additional tokens for the index, if there is one.
*/
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 |
* 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;
| | | 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
* 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;
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
TclStackFree(interp, parsePtr);
return NULL;
}
if (termPtr != NULL) {
|
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
* the terminating '}' if the parse was
* successful. */
{
Tcl_Token *tokenPtr;
const char *src;
int startIndex, level, length;
| < < < | < > > > | 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
* the terminating '}' if the parse was
* successful. */
{
Tcl_Token *tokenPtr;
const char *src;
int startIndex, level, length;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
src = start;
startIndex = parsePtr->numTokens;
TclGrowParseTokenArray(parsePtr, 1);
tokenPtr = &parsePtr->tokenPtr[startIndex];
|
| ︙ | ︙ | |||
1757 1758 1759 1760 1761 1762 1763 |
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
| | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && TclIsSpaceProcM(src[-1])) {
Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
": possible unbalanced brace in comment", -1);
goto error;
}
break;
}
}
|
| ︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 |
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the quoted string's terminating close-quote
* if the parse succeeds. */
{
| < < < | < > > > | 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 |
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the quoted string's terminating close-quote
* if the parse succeeds. */
{
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
|
| ︙ | ︙ | |||
2008 2009 2010 2011 2012 2013 2014 | * within that substitution until we reach the actual parse * error. We'll do additional parsing to determine what length * to claim for the final TCL_TOKEN_COMMAND token. */ Tcl_Token *tokenPtr; const char *lastTerm = parsePtr->term; | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 |
* within that substitution until we reach the actual parse
* error. We'll do additional parsing to determine what length
* to claim for the final TCL_TOKEN_COMMAND token.
*/
Tcl_Token *tokenPtr;
const char *lastTerm = parsePtr->term;
Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
while (TCL_OK ==
Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) {
Tcl_FreeParse(nestedPtr);
p = nestedPtr->term + (nestedPtr->term < nestedPtr->end);
length = nestedPtr->end - p;
|
| ︙ | ︙ | |||
2101 2102 2103 2104 2105 2106 2107 |
const char *outerScript) /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'.
* The 'clNextOuter' refers to the current
* entry in the table of continuation lines in
| | | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
const char *outerScript) /* continuation line data. This is set by
* EvalEx() to properly handle [...]-nested
* commands. The 'outerScript' refers to the
* most-outer script containing the embedded
* command, which is refered to by 'script'.
* The 'clNextOuter' refers to the current
* entry in the table of continuation lines in
* this "main script", and the character
* offsets are relative to the 'outerScript'
* as well.
*
* If outerScript == script, then this call is
* for words in the outer-most script or
* command. See Tcl_EvalEx and TclEvalObjEx
* for the places generating arguments for
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
result = NULL;
for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
Tcl_Obj *appendObj = NULL;
const char *append = NULL;
|
| ︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 |
clPos = 0;
} else {
TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
| | | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 |
clPos = 0;
} else {
TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CommandComplete(
const char *script, /* Script to check. */
int numBytes) /* Number of bytes in script. */
{
Tcl_Parse parse;
const char *p, *end;
int result;
|
| ︙ | ︙ |
Changes to generic/tclPathObj.c.
1 2 3 4 5 6 7 | /* * tclPathObj.c -- * * This file contains the implementation of Tcl's "path" object type used * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclPathObj.c -- * * This file contains the implementation of Tcl's "path" object type used * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. * * Copyright © 2003 Vince 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 "tclFileSystem.h" |
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
* it is the root of an absolute path.
*/
if ((splitElements > 0) && ((splitElements > 1) ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
} else {
| | | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 |
* it is the root of an absolute path.
*/
if ((splitElements > 0) && ((splitElements > 1) ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
} else {
TclNewObj(resultPtr);
}
} else {
/*
* Return all but the last component. If there is only one
* component, return it if the path was non-relative, otherwise
* return the current directory.
*/
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
{
const char *tail, *extension;
Tcl_Obj *ret;
tail = TclGetString(pathPtr);
extension = TclGetExtension(tail);
if (extension == NULL) {
| | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
{
const char *tail, *extension;
Tcl_Obj *ret;
tail = TclGetString(pathPtr);
extension = TclGetExtension(tail);
if (extension == NULL) {
TclNewObj(ret);
} else {
ret = Tcl_NewStringObj(extension, -1);
}
Tcl_IncrRefCount(ret);
return ret;
}
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
/*
* The path element was not of a suitable form to be returned as is.
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
| | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 |
/*
* The path element was not of a suitable form to be returned as is.
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
ptr = TclGetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the beginning of
* the path.
*/
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len);
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
| | | | 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len);
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
TclNewObj(pathPtr);
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
*/
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
|
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 | * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclFSMakePathRelative( | | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclFSMakePathRelative(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* The path we have. */
Tcl_Obj *cwdPtr) /* Make it relative to this. */
{
int cwdLen, len;
const char *tempStr;
Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType);
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 | * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ static int MakePathFromNormalized( | | | | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
MakePathFromNormalized(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
*/
fsPathPtr->translatedPathPtr = NULL;
|
| ︙ | ︙ | |||
1529 1530 1531 1532 1533 1534 1535 |
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
| | | 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 |
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
const char *orig = TclGetStringFromObj(transPtr, &len);
| | | 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
const char *orig = TclGetStringFromObj(transPtr, &len);
char *result = (char *)ckalloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
return NULL;
|
| ︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 |
char *nativePathPtr;
proc = srcFsPathPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
| | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
char *nativePathPtr;
proc = srcFsPathPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
}
return srcFsPathPtr->nativePathPtr;
}
|
| ︙ | ︙ | |||
2342 2343 2344 2345 2346 2347 2348 |
}
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
| | | 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 |
}
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
if (transPtr == pathPtr) {
transPtr = Tcl_DuplicateObj(pathPtr);
fsPathPtr->filesystemEpoch = 0;
} else {
fsPathPtr->filesystemEpoch = TclFSEpoch();
}
|
| ︙ | ︙ | |||
2402 2403 2404 2405 2406 2407 2408 |
static void
DupFsPathInternalRep(
Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
| | | 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 |
static void
DupFsPathInternalRep(
Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != NULL) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 |
*
*---------------------------------------------------------------------------
*/
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
| | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 |
*
*---------------------------------------------------------------------------
*/
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
TCL_UNUSED(ClientData *))
{
/*
* A special case is required to handle the empty path "". This is a valid
* path (i.e. the user should be able to do 'file exists ""' without
* throwing an error), but equally the path doesn't exist. Those are the
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
1 2 3 4 5 6 | /* * tclPipe.c -- * * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclPipe.c -- * * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. * * Copyright © 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" |
| ︙ | ︙ | |||
184 185 186 187 188 189 190 |
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
| | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = (Detached *)ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
*/
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, 0, SEEK_SET);
| | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
*/
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, 0, SEEK_SET);
TclNewObj(objPtr);
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading stderr output file: %s",
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
| | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
const char *oldName;
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
1 2 3 4 5 6 | /* * tclPkg.c -- * * This file implements package and version control for Tcl via the * "package" command and a few C APIs. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclPkg.c -- * * This file implements package and version control for Tcl via the * "package" command and a few C APIs. * * Copyright © 1996 Sun Microsystems, Inc. * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
/*
* Helper macros.
*/
#define DupBlock(v,s,len) \
((v) = (char *)ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
/*
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
| | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
TCL_UNUSED(Tcl_Interp *))
{
PkgFiles *pkgFiles = (PkgFiles *) clientData;
Tcl_HashSearch search;
Tcl_HashEntry *entry;
while (pkgFiles->names) {
PkgName *name = pkgFiles->names;
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
TclInitPkgFiles(
Tcl_Interp *interp)
{
/*
* If assocdata "tclPkgFiles" doesn't exist yet, create it.
*/
| | | | | | | 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 |
TclInitPkgFiles(
Tcl_Interp *interp)
{
/*
* If assocdata "tclPkgFiles" doesn't exist yet, create it.
*/
PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (!pkgFiles) {
pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles));
pkgFiles->names = NULL;
Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
}
return pkgFiles;
}
void
TclPkgFileSeen(
Tcl_Interp *interp,
const char *fileName)
{
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles && pkgFiles->names) {
const char *name = pkgFiles->names->name;
Tcl_HashTable *table = &pkgFiles->table;
int isNew;
Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew);
Tcl_Obj *list;
if (isNew) {
TclNewObj(list);
Tcl_SetHashValue(entry, list);
Tcl_IncrRefCount(list);
} else {
list = (Tcl_Obj *)Tcl_GetHashValue(entry);
}
Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
}
}
#undef Tcl_PkgRequire
const char *
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
static int
TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
Tcl_Obj *const reqv[])
{
| | | | | | | | | | | | | 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 |
static int
TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
Tcl_Obj *const reqv[])
{
RequireProcArgs *args = (RequireProcArgs *)clientData;
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
args->clientDataPtr);
return TCL_OK;
}
static int
PkgRequireCore(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
const char *name = (const char *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **reqv = (Tcl_Obj **)data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
if (code != TCL_OK) {
return code;
}
reqPtr = (Require *)ckalloc(sizeof(Require));
Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
reqPtr->clientDataPtr = data[3];
reqPtr->name = name;
reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), reqv,
(void *)PkgRequireCoreStep1);
} else {
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL);
}
return TCL_OK;
}
static int
PkgRequireCoreStep1(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
Tcl_DString command;
char *script;
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name /* Name of desired package. */;
/*
* If we've got the package in the DB already, go on to actually loading
* it.
*/
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
static int
PkgRequireCoreStep2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
static int
PkgRequireCoreStep2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = (Require *)data[0];
int reqc = 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", NULL);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
/*
* pkgPtr may now be invalid, so refresh it.
*/
reqPtr->pkgPtr = FindPackage(interp, name);
Tcl_NRAddCallback(interp,
| | | | | | | 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 |
/*
* pkgPtr may now be invalid, so refresh it.
*/
reqPtr->pkgPtr = FindPackage(interp, name);
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), reqv,
(void *)PkgRequireCoreFinal);
return TCL_OK;
}
static int
PkgRequireCoreFinal(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]), satisfies;
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
const char *name = reqPtr->name; /* Name of desired package. */
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
PkgRequireCoreCleanup(
ClientData data[],
| | | | | | 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 |
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
PkgRequireCoreCleanup(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
ckfree(data[0]);
return result;
}
static int
SelectPackage(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
/*
* Check whether we're already attempting to load some version of this
* package (circular dependency detection).
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
&& (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
}
if (bestPtr == NULL) {
Tcl_NRAddCallback(interp,
| | | | | 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 |
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
&& (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
}
if (bestPtr == NULL) {
Tcl_NRAddCallback(interp,
(Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
} else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
* script itself from deletion and (b) don't assume that bestPtr will
* still exist when the script completes.
*/
char *versionToProvide = bestPtr->version;
PkgFiles *pkgFiles;
PkgName *pkgName;
Tcl_Preserve(versionToProvide);
pkgPtr->clientData = versionToProvide;
pkgFiles = (PkgFiles *)TclInitPkgFiles(interp);
/*
* Push "ifneeded" package name in "tclPkgFiles" assocdata.
*/
pkgName = (PkgName *)ckalloc(sizeof(PkgName) + strlen(name));
pkgName->nextPtr = pkgFiles->names;
strcpy(pkgName->name, name);
pkgFiles->names = pkgName;
if (bestPtr->pkgIndex) {
TclPkgFileSeen(interp, bestPtr->pkgIndex);
}
reqPtr->versionToProvide = versionToProvide;
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
static int
SelectPackageFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | 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 |
static int
SelectPackageFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
/*
* Pop the "ifneeded" package name from "tclPkgFiles" assocdata
*/
PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
PkgName *pkgName = pkgFiles->names;
pkgFiles->names = pkgName->nextPtr;
ckfree(pkgName);
reqPtr->pkgPtr = FindPackage(interp, name);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", NULL);
}
}
}
} else if (result != TCL_ERROR) {
| | > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
"WRONGPROVIDE", 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", NULL);
TclDecrRefCount(codePtr);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
return result;
}
Tcl_NRAddCallback(interp,
| | | 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
return result;
}
Tcl_NRAddCallback(interp,
(Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresent / Tcl_PkgPresentEx --
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
| | | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement by
* calling Tcl_PkgRequireEx() to check for us.
*/
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PackageObjCmd( | | | < | | | 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 |
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PackageObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
int
TclNRPackageObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
"files", "forget", "ifneeded", "names", "prefer",
"present", "provide", "require", "unknown", "vcompare",
"versions", "vsatisfies", NULL
};
enum pkgOptionsEnum {
PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER,
PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, newobjc, satisfies;
PkgAvail *availPtr, *prevPtr;
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 |
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum pkgOptionsEnum) optionIndex) {
case PKG_FILES: {
PkgFiles *pkgFiles;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1123 1124 1125 1126 1127 1128 1129 |
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
| | | | 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 |
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
Tcl_DecrRefCount(obj);
}
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
argv2 = TclGetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
ckfree(argv3i);
return TCL_OK;
}
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
argv2 = TclGetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
ckfree(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) {
|
| ︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 |
}
ckfree(argv3i);
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
| | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
}
ckfree(argv3i);
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail));
availPtr->pkgIndex = NULL;
DupBlock(availPtr->version, argv3, length + 1);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
} else {
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
case PKG_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultObj;
| | | | | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
case PKG_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
(char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, resultObj);
}
break;
case PKG_PRESENT: {
const char *name;
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
} else {
exact = 0;
name = argv2;
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
| | | 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 |
} else {
exact = 0;
name = argv2;
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
goto require;
}
}
version = NULL;
if (exact) {
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
| | | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 |
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp, pkgPtr->version);
}
}
return TCL_OK;
}
argv3 = TclGetString(objv[3]);
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 |
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
} else {
| < > | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
} else {
Tcl_Obj *const *newobjv = objv + 3;
newobjc = objc - 3;
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_IncrRefCount(objv[2]);
for (i = 0; i < newobjc; i++) {
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 | } /* * Comparison is done on the internal representation. */ Tcl_SetObjResult(interp, | | | > | | 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 |
}
/*
* Comparison is done on the internal representation.
*/
Tcl_SetObjResult(interp,
Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL)));
ckfree(iva);
ckfree(ivb);
break;
case PKG_VERSIONS:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
} else {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
argv2 = TclGetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(availPtr->version, -1));
}
}
Tcl_SetObjResult(interp, resultObj);
|
| ︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 |
}
return TCL_OK;
}
static int
TclNRPackageObjCmdCleanup(
ClientData data[],
| | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 |
}
return TCL_OK;
}
static int
TclNRPackageObjCmdCleanup(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
TclDecrRefCount((Tcl_Obj *) data[0]);
TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
|
| ︙ | ︙ | |||
1570 1571 1572 1573 1574 1575 1576 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
| | | | 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
pkgPtr = (Package *)ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
}
return pkgPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 |
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
|
| ︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
| | | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
char *ibuf = (char *)ckalloc(4 + 4*strlen(string));
char *ip = ibuf;
/*
* Basic rules
* (1) First character has to be a digit.
* (2) All other characters have to be a digit or '.'
* (3) Two '.'s may not follow each other.
|
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
* Syntax of requirement = version
* = version-version
* = version-
*/
char *dash = NULL, *buf;
| | | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 |
* Syntax of requirement = version
* = version-version
* = version-
*/
char *dash = NULL, *buf;
dash = (char *)strchr(string, '-');
if (dash == NULL) {
/*
* No dash found, has to be a simple version.
*/
return CheckVersionAndConvert(interp, string, NULL, NULL);
}
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
/*
* The have candidate is already in internal rep.
*/
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
| | | 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 |
/*
* The have candidate is already in internal rep.
*/
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
dash = (char *)strchr(req, '-');
if (dash == NULL) {
/*
* No dash found, is a simple version, fallback to regular check. The
* 'CheckVersionAndConvert' cannot fail. We pad the requirement with
* 'a0', i.e '-2' before doing the comparison to properly accept
* unstables as well.
*/
|
| ︙ | ︙ |
Changes to generic/tclPkgConfig.c.
1 2 3 4 5 6 | /* * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl * binary library. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl * binary library. * * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* Note, the definitions in this module are influenced by the following C * preprocessor macros: |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 | * * - TCL_CFGVAL_ENCODING string containing the encoding used for the * configuration values. */ #include "tclInt.h" /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ #if TCL_THREADS # define CFG_THREADED "1" | > > > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | * * - TCL_CFGVAL_ENCODING string containing the encoding used for the * configuration values. */ #include "tclInt.h" #ifndef TCL_CFGVAL_ENCODING # define TCL_CFGVAL_ENCODING "utf-8" #endif /* * Use C preprocessor statements to define the various values for the embedded * configuration information. */ #if TCL_THREADS # define CFG_THREADED "1" |
| ︙ | ︙ |
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar | > > > > > | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar |
| ︙ | ︙ |
Changes to generic/tclPosixStr.c.
1 2 3 4 5 6 | /* * tclPosixStr.c -- * * This file contains procedures that generate strings corresponding to * various POSIX-related codes, such as errno and signals. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclPosixStr.c -- * * This file contains procedures that generate strings corresponding to * various POSIX-related codes, such as errno and signals. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 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. */ #include "tclInt.h" |
| ︙ | ︙ |
Changes to generic/tclPreserve.c.
1 2 3 4 5 6 7 | /* * tclPreserve.c -- * * This file contains a collection of functions that are used to make * sure that widget records and other data structures aren't reallocated * when there are nested functions that depend on their existence. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclPreserve.c -- * * This file contains a collection of functions that are used to make * sure that widget records and other data structures aren't reallocated * when there are nested functions that depend on their existence. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1998 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" |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | * * Side effects: * Frees the storage of the reference array. * *---------------------------------------------------------------------- */ | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
*
* Side effects:
* Frees the storage of the reference array.
*
*----------------------------------------------------------------------
*/
void
TclFinalizePreserve(void)
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
ckfree(refArray);
refArray = NULL;
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
| | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference));
}
/*
* Make a new entry for the new reference.
*/
refPtr = &refArray[inUse];
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
| | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
freeProc((char *)clientData);
}
}
return;
}
Tcl_MutexUnlock(&preserveMutex);
/*
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
| | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
freeProc((char *)clientData);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandleCreate --
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
| | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
handlePtr->ptr2 = ptr;
#endif
handlePtr->refCount = 0;
return (TclHandle) handlePtr;
|
| ︙ | ︙ |
Changes to generic/tclProc.c.
1 2 3 4 5 6 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2004-2006 Miguel Sofer * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * * 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 "tclCompile.h" |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | /* * Prototypes for static functions in this file */ static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); | | < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | /* * Prototypes for static functions in this file */ static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); static int InitArgsAndLocals(Tcl_Interp *interp, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 |
Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
| | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
(procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
} while (0)
#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &lambdaType); \
| | | < | | 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 |
Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
} while (0)
#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((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
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
int
Tcl_ProcObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
const char *procName;
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
| | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
objv[3], &procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
* this file. The differences are the different index of the body in the
* line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
if (iPtr->cmdFramePtr) {
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
* this file. The differences are the different index of the body in the
* line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
if (iPtr->cmdFramePtr) {
CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
if (contextPtr->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
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
| | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 | /* * Get the old command frame and release it. See also * TclProcCleanupProc in this file. Currently it seems as * if only the procbodytest::proc command of the testsuite * is able to trigger this situation. */ | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
/*
* Get the old command frame and release it. See also
* TclProcCleanupProc in this file. Currently it seems as
* if only the procbodytest::proc command of the testsuite
* is able to trigger this situation.
*/
CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
ckfree(cfOldPtr->line);
cfOldPtr->line = NULL;
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
*
*----------------------------------------------------------------------
*/
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
| | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
*
*----------------------------------------------------------------------
*/
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
TCL_UNUSED(Namespace *) /*nsPtr*/,
const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); procPtr = (Proc *)ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; |
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength); /* * Check that the formal parameter name is a scalar. */ argnamei = argname; | | | | 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 |
argname = Tcl_GetStringFromObj(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",
Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if (*argnamei == ':' && *(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", NULL);
goto procError;
}
argnamei++;
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one. Note that the
* only flag value that makes sense at this point is VAR_ARGUMENT
* (its value was kept the same as pre VarReform to simplify
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
| > | | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
localPtr = (CompiledLocal *)ckalloc(
offsetof(CompiledLocal, name) + fieldValues[0]->length + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
static int
Uplevel_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | < | | | > > > > > > > > > > > > > > > > > > > > > | 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 |
static int
Uplevel_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallFrame *savedVarFramePtr = (CallFrame *)data[0];
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
}
/*
* Restore the variable frame, and return.
*/
((Interp *)interp)->varFramePtr = savedVarFramePtr;
return result;
}
int
Tcl_UplevelObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv);
}
int
TclNRUplevelObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
Tcl_Obj *objPtr;
if (objc < 2) {
/* to do
* simplify things by interpreting the argument as a command when there
* is only one argument. This requires a TIP since currently a single
* argument is interpreted as a level indicator if possible.
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
int status ,llength;
status = Tcl_ListObjLength(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;
}
objc -= 1;
objv += 1;
goto havelevel;
}
}
/*
* Find the level to use for executing the command.
*/
result = TclObjGetFrame(interp, objv[1], &framePtr);
if (result == -1) {
return TCL_ERROR;
}
objc -= result + 1;
if (objc == 0) {
goto uplevelSyntax;
}
objv += result + 1;
havelevel:
/*
* Modify the interpreter state to execute in the given frame.
*/
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 |
{
Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->deleteProc == TclProcDeleteProc) {
| | | | | 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 |
{
Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->deleteProc == TclProcDeleteProc) {
return (Proc *)cmdPtr->objClientData;
}
return NULL;
}
static int
ProcWrongNumArgs(
Tcl_Interp *interp,
int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
int localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
const char *final = NULL;
/*
* Build up desired argument list for Tcl_WrongNumArgs
*/
numArgs = framePtr->procPtr->numArgs;
desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
sizeof(Tcl_Obj *) * (numArgs+1));
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
#else
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 |
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
| | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0)
+ localCt * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
localPtr = procPtr->firstLocalPtr;
while (localPtr) {
if (TclIsVarTemporary(localPtr)) {
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
*----------------------------------------------------------------------
*/
static int
InitArgsAndLocals(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
| < | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
*----------------------------------------------------------------------
*/
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;
Var *varPtr, *defPtr;
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 |
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
* parameters.
*/
| | | 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 |
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
* parameters.
*/
varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var));
framePtr->compiledLocals = varPtr;
framePtr->numCompiledLocals = localCt;
/*
* Match and assign the call's actual parameters to the procedure's formal
* arguments. The formal arguments are described by the first numArgs
* entries in both the Proc structure's local variable list and the call
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
* invoked. */
int 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 */
{
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
* invoked. */
int 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 */
{
Proc *procPtr = (Proc *)clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
ByteCode *codePtr;
/*
* If necessary (i.e. if we haven't got a suitable compilation already
|
| ︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 |
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
ByteCode *codePtr;
| | | 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 |
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
ByteCode *codePtr;
result = InitArgsAndLocals(interp, skip);
if (result != TCL_OK) {
freePtr = iPtr->framePtr;
Tcl_PopCallFrame(interp); /* Pop but do not free. */
TclStackFree(interp, freePtr->compiledLocals);
/* Free compiledLocals. */
TclStackFree(interp, freePtr); /* Free CallFrame. */
return TCL_ERROR;
|
| ︙ | ︙ | |||
1780 1781 1782 1783 1784 1785 1786 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
| | | 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 | TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); } #endif /* * Plug the current procPtr into the interpreter and coerce the code * body to byte codes. The interpreter needs to know which proc it's * compiling so that it can access its list of compiled locals. * | > > > | 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 |
TclNewLiteralStringObj(message, "Compiling ");
Tcl_IncrRefCount(message);
Tcl_AppendStringsToObj(message, description, " \"", NULL);
Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
#else
(void)description;
(void)procName;
#endif
/*
* Plug the current procPtr into the interpreter and coerce the code
* body to byte codes. The interpreter needs to know which proc it's
* compiling so that it can access its list of compiled locals.
*
|
| ︙ | ︙ | |||
2018 2019 2020 2021 2022 2023 2024 | hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr); /* * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. */ iPtr->invokeWord = 0; | | | 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
/*
* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
*/
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL;
TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
/*
* The resolver epoch has changed, but we only need to invalidate the
* resolver cache.
|
| ︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 |
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
| | | 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 |
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
/*
|
| ︙ | ︙ | |||
2168 2169 2170 2171 2172 2173 2174 |
}
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
if (!hePtr) {
return;
}
| | | 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 |
}
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
if (!hePtr) {
return;
}
cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
ckfree(cfPtr->line);
|
| ︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 |
* this file. The differences are the different index of the body in the
* line array of the context, and the special processing mentioned in the
* previous paragraph to track into the list. Find a way to factor the
* common elements into a single function.
*/
if (iPtr->cmdFramePtr) {
| | | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 |
* this file. The differences are the different index of the body in the
* line array of the context, and the special processing mentioned in the
* previous paragraph to track into the list. Find a way to factor the
* common elements into a single function.
*/
if (iPtr->cmdFramePtr) {
CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve the source context from the bytecode. This call
* accounts for the reference to the source file, if any, held in
* 'context.data.eval.path'.
|
| ︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ | | | | 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); |
| ︙ | ︙ | |||
2615 2616 2617 2618 2619 2620 2621 | * Depends on the content of the lambda term (i.e., objv[1]). * *---------------------------------------------------------------------- */ int Tcl_ApplyObjCmd( | | | | | 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 |
* Depends on the content of the lambda term (i.e., objv[1]).
*
*----------------------------------------------------------------------
*/
int
Tcl_ApplyObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv);
}
int
TclNRApplyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result;
|
| ︙ | ︙ | |||
2663 2664 2665 2666 2667 2668 2669 |
*/
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
| | | 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 |
*/
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData));
memset(&extraPtr->cmd, 0, sizeof(Command));
procPtr->cmdPtr = &extraPtr->cmd;
extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
/*
* TIP#280 (semi-)HACK!
*
|
| ︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 |
static int
ApplyNR2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 |
static int
ApplyNR2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ApplyExtraData *extraPtr = (ApplyExtraData *)data[0];
TclStackFree(interp, extraPtr);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
1 2 3 4 5 6 | /* * tclProcess.c -- * * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclProcess.c -- * * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. * * Copyright © 2017 Frederic Bonnet. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
return TCL_PROCESS_UNCHANGED;
}
/*
* Get process status.
*/
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
return TCL_PROCESS_UNCHANGED;
}
/*
* Get process status.
*/
if (pid == (Tcl_Pid)-1) {
/*
* POSIX errName msg
*/
msg = Tcl_ErrnoMsg(errno);
if (errno == ECHILD) {
/*
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
* 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);
| | | | | | | 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 |
* 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;
}
}
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
return Tcl_NewObj();
}
if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
/*
* Normal exit, return TCL_OK.
*/
| | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
return Tcl_NewObj();
}
if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
/*
* Normal exit, return TCL_OK.
*/
return Tcl_NewWideIntObj(TCL_OK);
}
/*
* Abnormal exit, return {TCL_ERROR msg error}
*/
TclNewIntObj(resultObjs[0], TCL_ERROR);
resultObjs[1] = info->msg;
resultObjs[2] = info->error;
return Tcl_NewListObj(3, resultObjs);
}
/*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | * Access to the internal structures is protected by infoTablesMutex. * *---------------------------------------------------------------------- */ static int ProcessListObjCmd( | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
* Access to the internal structures is protected by infoTablesMutex.
*
*----------------------------------------------------------------------
*/
static int
ProcessListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *list;
Tcl_HashEntry *entry;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
list = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&infoTablesMutex);
for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
info = (ProcessInfo *) Tcl_GetHashValue(entry);
Tcl_ListObjAppendElement(interp, list,
| | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
list = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&infoTablesMutex);
for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
info = (ProcessInfo *) Tcl_GetHashValue(entry);
Tcl_ListObjAppendElement(interp, list,
Tcl_NewWideIntObj(info->resolvedPid));
}
Tcl_MutexUnlock(&infoTablesMutex);
Tcl_SetObjResult(interp, list);
return TCL_OK;
}
/*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | * Calls RefreshProcessInfo, which can block if -wait switch is given. * *---------------------------------------------------------------------- */ static int ProcessStatusObjCmd( | | | | | 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 |
* Calls RefreshProcessInfo, which can block if -wait switch is given.
*
*----------------------------------------------------------------------
*/
static int
ProcessStatusObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dict;
int index, options = WNOHANG;
Tcl_HashEntry *entry;
Tcl_HashSearch search;
ProcessInfo *info;
int numPids;
Tcl_Obj **pidObjs;
int result;
int i;
int pid;
Tcl_Obj *const *savedobjv = objv;
static const char *const switches[] = {
"-wait", "--", NULL
};
enum switchesEnum {
STATUS_WAIT, STATUS_LAST
};
while (objc > 1) {
if (TclGetString(objv[1])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
++objv; --objc;
if (STATUS_WAIT == (enum switchesEnum) index) {
options = 0;
} else {
break;
}
}
if (objc != 1 && objc != 2) {
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
Tcl_MutexUnlock(&infoTablesMutex);
} else {
/*
* Only return statuses of provided processes.
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
| | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
Tcl_DeleteHashEntry(entry);
FreeProcessInfo(info);
} else {
/*
* Add to result.
*/
Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid),
BuildProcessStatusObj(info));
}
}
Tcl_MutexUnlock(&infoTablesMutex);
}
Tcl_SetObjResult(interp, dict);
return TCL_OK;
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | * Frees all ProcessInfo structures with their purge flag set. * *---------------------------------------------------------------------- */ static int ProcessPurgeObjCmd( | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
* Frees all ProcessInfo structures with their purge flag set.
*
*----------------------------------------------------------------------
*/
static int
ProcessPurgeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_HashEntry *entry;
Tcl_HashSearch search;
ProcessInfo *info;
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | * Alters detached process handling by Tcl_ReapDetachedProcs(). * *---------------------------------------------------------------------- */ static int ProcessAutopurgeObjCmd( | | > | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
* Alters detached process handling by Tcl_ReapDetachedProcs().
*
*----------------------------------------------------------------------
*/
static int
ProcessAutopurgeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1 && objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
return TCL_ERROR;
}
if (objc == 2) {
/*
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
FreeProcessInfo(info);
}
/*
* Allocate and initialize info structure.
*/
| | | 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
FreeProcessInfo(info);
}
/*
* Allocate and initialize info structure.
*/
info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo));
InitProcessInfo(info, pid, resolvedPid);
/*
* Add entry to tables.
*/
Tcl_SetHashValue(entry, info);
|
| ︙ | ︙ |
Changes to generic/tclRegexp.c.
1 2 3 4 5 6 | /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular expression * mechanism. * | | | | | 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 | /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular expression * mechanism. * * Copyright © 1998 Sun Microsystems, Inc. * 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" #include "tclRegexp.h" #include <assert.h> /* *---------------------------------------------------------------------- * The routines in this file use Henry Spencer's regular expression package * contained in the following additional source files: * * regc_color.c regc_cvec.c regc_lex.c * regc_nfa.c regcomp.c regcustom.h * rege_dfa.c regerror.c regerrs.h * regex.h regexec.c regfree.c * regfronts.c regguts.h * * Copyright © 1998 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * * Redistribution and use in source and binary forms -- with or without |
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
} while (0)
#define RegexpGetIntRep(objPtr, rePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
} while (0)
#define RegexpGetIntRep(objPtr, rePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \
(rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpCompile --
|
| ︙ | ︙ | |||
672 673 674 675 676 677 678 |
/*
* Assume that there will never be more than INT_MAX subexpressions. This
* is a pretty reasonable assumption; the RE engine doesn't scale _that_
* well and Tcl has other limits that constrain things as well...
*/
| | > | < | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
/*
* Assume that there will never be more than INT_MAX subexpressions. This
* is a pretty reasonable assumption; the RE engine doesn't scale _that_
* well and Tcl has other limits that constrain things as well...
*/
TclNewObj(resultObj);
TclNewIntObj(infoObj, regexpPtr->re.re_nsub);
Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
/*
* Now append a list of all the bit-flags set for the RE.
*/
TclNewObj(infoObj);
for (inf=infonames ; inf->bit != 0 ; inf++) {
|
| ︙ | ︙ | |||
912 913 914 915 916 917 918 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
| | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
regexpPtr->details.rm_extend.rm_eo = -1;
/*
* Get the up-to-date string representation and map to unicode.
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
| | | 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
(regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
*/
regexpPtr->refCount = 1;
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 |
ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
}
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
| | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
}
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
tsdPtr->patterns[0] = (char *)ckalloc(length + 1);
memcpy(tsdPtr->patterns[0], string, length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
return regexpPtr;
}
|
| ︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 | * None. * *---------------------------------------------------------------------- */ static void FinalizeRegexp( | | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeRegexp(
TCL_UNUSED(ClientData))
{
int i;
TclRegexp *regexpPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
|
| ︙ | ︙ |
Changes to generic/tclResolve.c.
1 2 3 4 5 6 7 8 | /* * tclResolve.c -- * * Contains hooks for customized command/variable name resolution * schemes. These hooks allow extensions like [incr Tcl] to add their own * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclResolve.c -- * * Contains hooks for customized command/variable name resolution * schemes. These hooks allow extensions like [incr Tcl] to add their own * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. * * Copyright © 1998 Lucent Technologies, 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" |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
| | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme));
len = strlen(name) + 1;
resPtr->name = (char *)ckalloc(len);
memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
resPtr->nextPtr = iPtr->resolverPtr;
iPtr->resolverPtr = resPtr;
}
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
Tcl_HashSearch search;
nsPtr->cmdRefEpoch++;
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
| | | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
Tcl_HashSearch search;
nsPtr->cmdRefEpoch++;
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
Namespace *childNsPtr = (Namespace *)Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
#else
if (nsPtr->childTablePtr != NULL) {
for (entry = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
1 2 3 4 5 | /* * tclResult.c -- * * This file contains code to manage the interpreter result. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright © 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" |
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
Tcl_InterpState
Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
| | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
Tcl_InterpState
Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
statePtr->returnLevel = iPtr->returnLevel;
statePtr->returnCode = iPtr->returnCode;
statePtr->errorInfo = iPtr->errorInfo;
statePtr->errorStack = iPtr->errorStack;
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
/*
* Move the result object into the save state. Note that we don't need to
* change its refcount because we're moving it, not adding a new
* reference. Put an empty object into the interpreter.
*/
statePtr->objResultPtr = iPtr->objResultPtr;
| | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
/*
* Move the result object into the save state. Note that we don't need to
* change its refcount because we're moving it, not adding a new
* reference. Put an empty object into the interpreter.
*/
statePtr->objResultPtr = iPtr->objResultPtr;
TclNewObj(iPtr->objResultPtr);
Tcl_IncrRefCount(iPtr->objResultPtr);
/*
* Save the string result.
*/
statePtr->freeProc = iPtr->freeProc;
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
int length = strlen(result);
if (length > TCL_RESULT_SIZE) {
| | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
int length = strlen(result);
if (length > TCL_RESULT_SIZE) {
iPtr->result = (char *)ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
memcpy(iPtr->result, result, length+1);
} else {
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
#else
char *dst;
int size;
int flags;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
| > | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
#else
char *dst;
int size;
int flags;
int quoteHash = 1;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 | dst++; /* * If we need a space to separate this element from preceding stuff, * then this element will not lead a list, and need not have it's * leading '#' quoted. */ | > > > | > > > > > | 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 |
dst++;
/*
* If we need a space to separate this element from preceding stuff,
* then this element will not lead a list, and need not have it's
* leading '#' quoted.
*/
quoteHash = 0;
} else {
while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) {
}
quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1);
}
dst = iPtr->appendResult + iPtr->appendUsed;
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
#endif /* !TCL_NO_DEPRECATED */
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
*/
iPtr->appendUsed = strlen(iPtr->result);
}
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
| | | | | | 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 |
*/
iPtr->appendUsed = strlen(iPtr->result);
}
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
char *newSpacePtr;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
newSpacePtr = (char *)ckalloc(totalSpace);
strcpy(newSpacePtr, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
iPtr->appendResult = newSpacePtr;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
}
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
*/
void
Tcl_SetErrorCodeVA(
Tcl_Interp *interp, /* Interpreter in which to set errorCode */
va_list argList) /* Variable argument list. */
{
| | > | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
*/
void
Tcl_SetErrorCodeVA(
Tcl_Interp *interp, /* Interpreter in which to set errorCode */
va_list argList) /* Variable argument list. */
{
Tcl_Obj *errorObj;
/*
* Scan through the arguments one at a time, appending them to the
* errorCode field as list elements.
*/
TclNewObj(errorObj);
while (1) {
char *elem = va_arg(argList, char *);
if (elem == NULL) {
break;
}
Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
| | | | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey,
KEY_LAST * sizeof(Tcl_Obj *));
if (keys[0] == NULL) {
/*
* First call in this thread, create the keys...
*/
int i;
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 |
*----------------------------------------------------------------------
*/
static void
ReleaseKeys(
ClientData clientData)
{
| | | 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 |
*----------------------------------------------------------------------
*/
static void
ReleaseKeys(
ClientData clientData)
{
Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
keys[i] = NULL;
}
}
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 |
* -code value should be written. */
int *levelPtr) /* If not NULL, points to space where the
* -level value should be written. */
{
int code = TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
| | > | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 |
* -code value should be written. */
int *levelPtr) /* If not NULL, points to space where the
* -level value should be written. */
{
int code = TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
Tcl_Obj *returnOpts;
Tcl_Obj **keys = GetKeys();
TclNewObj(returnOpts);
for (; objc > 1; objv += 2, objc -= 2) {
const char *opt = TclGetString(objv[0]);
const char *compare = TclGetString(keys[KEY_OPTIONS]);
if ((objv[0]->length == keys[KEY_OPTIONS]->length)
&& (memcmp(opt, compare, objv[0]->length) == 0)) {
Tcl_DictSearch search;
|
| ︙ | ︙ | |||
1578 1579 1580 1581 1582 1583 1584 |
Interp *iPtr = (Interp *) interp;
Tcl_Obj *options;
Tcl_Obj **keys = GetKeys();
if (iPtr->returnOpts) {
options = Tcl_DuplicateObj(iPtr->returnOpts);
} else {
| | | | | | | | 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 |
Interp *iPtr = (Interp *) interp;
Tcl_Obj *options;
Tcl_Obj **keys = GetKeys();
if (iPtr->returnOpts) {
options = Tcl_DuplicateObj(iPtr->returnOpts);
} else {
TclNewObj(options);
}
if (result == TCL_RETURN) {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
Tcl_NewWideIntObj(iPtr->returnCode));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
Tcl_NewWideIntObj(iPtr->returnLevel));
} else {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
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],
Tcl_NewWideIntObj(iPtr->errorLine));
}
return options;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
1 2 3 4 5 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright © 1998 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" #include "tclTomMath.h" |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 |
#define SCAN_LONGER 0x400 /* Asked for a wide value. */
#define SCAN_BIG 0x800 /* Asked for a bignum value. */
/*
* The following structure contains the information associated with a
* character set.
*/
typedef struct CharSet {
int exclude; /* 1 if this is an exclusion set. */
int nchars;
Tcl_UniChar *chars;
int nranges;
| > > > > > < < < | | 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 |
#define SCAN_LONGER 0x400 /* Asked for a wide value. */
#define SCAN_BIG 0x800 /* Asked for a bignum value. */
/*
* The following structure contains the information associated with a
* character set.
*/
typedef struct {
Tcl_UniChar start;
Tcl_UniChar end;
} Range;
typedef struct CharSet {
int exclude; /* 1 if this is an exclusion set. */
int nchars;
Tcl_UniChar *chars;
int nranges;
Range *ranges;
} CharSet;
/*
* Declarations for functions used only in this file.
*/
static const char * BuildCharSet(CharSet *cset, const char *format);
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
| | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
if (nranges > 0) {
cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges);
} else {
cset->ranges = NULL;
}
/*
* Now build the character set.
*/
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
int *totalSubs) /* The number of variables that will be
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
int *totalSubs) /* The number of variables that will be
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int));
Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
* these are messy operations because we do
* not want to use the formatting engine;
* we're inside there! */
char buf[5] = "";
/*
|
| ︙ | ︙ | |||
473 474 475 476 477 478 479 |
value = nspace;
if (xpgSize) {
nspace = xpgSize;
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
| | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
value = nspace;
if (xpgSize) {
nspace = xpgSize;
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
nassign = (int *)TclStackRealloc(interp, nassign,
nspace * sizeof(int));
for (i = value; i < nspace; i++) {
nassign[i] = 0;
}
}
nassign[objIndex]++;
objIndex++;
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
| | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetString(objv[1]);
baseString = string;
|
| ︙ | ︙ | |||
711 712 713 714 715 716 717 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
| | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
TclNewIntObj(objPtr, string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 | break; } case 'c': /* * Scan a single Unicode character. */ | | < < < < < < < | | | | 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 |
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUCS4(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) {
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
}
} else {
TclSetIntObj(objPtr, wideValue);
}
} else if (flags & SCAN_BIG) {
if (flags & SCAN_UNSIGNED) {
mp_int big;
| | | | | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
}
} else {
TclSetIntObj(objPtr, wideValue);
}
} else if (flags & SCAN_BIG) {
if (flags & SCAN_UNSIGNED) {
mp_int big;
int res = Tcl_GetBignumFromObj(interp, objPtr, &big);
if (res == TCL_OK) {
if (mp_isneg(&big)) {
res = TCL_ERROR;
}
mp_clear(&big);
}
if (res == TCL_ERROR) {
if (objs != NULL) {
ckfree(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 |
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
| | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 |
Tcl_DecrRefCount(objs[i]);
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
*/
| | | | | | 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 |
Tcl_DecrRefCount(objs[i]);
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
*/
TclNewObj(objPtr);
for (i = 0; i < totalVars; i++) {
if (objs[i] != NULL) {
Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
Tcl_DecrRefCount(objs[i]);
} else {
/*
* More %-specifiers than matching chars, so we just spit out
* empty strings for these.
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
ckfree(objs);
}
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
TclNewIntObj(objPtr, TCL_INDEX_NONE);
} else {
if (objPtr) {
Tcl_SetListObj(objPtr, 0, NULL);
} else {
TclNewObj(objPtr);
}
}
} else if (numVars) {
TclNewIntObj(objPtr, result);
}
Tcl_SetObjResult(interp, objPtr);
}
return code;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclStrToD.c.
1 2 3 4 5 6 7 8 9 | /* * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions * to/from floating-point in Tcl. They include TclParseNumber, which * parses numbers from strings; TclDoubleDigits, which formats numbers * into strings of digits, and procedures for interconversion among * 'double' and 'mp_int' types. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions * to/from floating-point in Tcl. They include TclParseNumber, which * parses numbers from strings; TclDoubleDigits, which formats numbers * into strings of digits, and procedures for interconversion among * 'double' and 'mp_int' types. * * Copyright © 2005 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" |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027F
# define ADJUST_FPU_CONTROL_WORD
#define TCL_IEEE_DOUBLE_ROUNDING \
fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
fpu_control_t oldRoundingMode; \
_FPU_GETCW(oldRoundingMode); \
_FPU_SETCW(roundTo53Bits)
#define TCL_DEFAULT_DOUBLE_ROUNDING \
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa # define NAN_START 0x7FF4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else # define NAN_START 0x7FF8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* * Constants used by this file (most of which are only ever calculated at * runtime). */ |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | /* * 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. */ | | | | | | 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 | /* * 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. */ #define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32) /* Hidden 1 bit for the significand. */ #define HI_ORDER_SIG_MASK 0x000FFFFF /* Mask for the high-order part of the * significand in the first word of a * double. */ #define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \ | 0xFFFFFFFF) /* Mask for the 52-bit significand. */ #define FP_PRECISION 53 /* Number of bits of significand plus the * hidden bit. */ #define EXPONENT_BIAS 0x3FF /* Bias of the exponent 0. */ /* * Derived quantities. */ #define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */ #define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */ |
| ︙ | ︙ | |||
324 325 326 327 328 329 330 | char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); | | | | | 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 | char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); static char * StrictInt64Conversion(Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversionPowD( Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, mp_int *, int); static char * ShorteningBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversion( Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); |
| ︙ | ︙ | |||
531 532 533 534 535 536 537 538 539 540 541 542 543 544 |
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
mp_err err = MP_OKAY;
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
| > > | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
mp_err err = MP_OKAY;
int under = 0; /* Flag trailing '_' as error if true once
* number is accepted. */
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 | case INITIAL: /* * Initial state. Acceptable characters are +, -, digits, period, * I, N, and whitespace. */ | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
case INITIAL:
/*
* Initial state. Acceptable characters are +, -, digits, period,
* I, N, and whitespace.
*/
if (TclIsSpaceProcM(c)) {
if (flags & TCL_PARSE_NO_WHITESPACE) {
goto endgame;
}
break;
} else if (c == '+') {
state = SIGNUM;
break;
|
| ︙ | ︙ | |||
639 640 641 642 643 644 645 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
| | | > > > > > > | 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 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) {
goto endgame;
}
state = ZERO_X;
break;
}
if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
goto zerox;
}
if (flags & TCL_PARSE_SCAN_PREFIXES) {
goto zeroo;
}
if (c == 'b' || c == 'B') {
if ((flags & TCL_PARSE_OCTAL_ONLY) || under) {
goto endgame;
}
state = ZERO_B;
break;
}
if (flags & TCL_PARSE_BINARY_ONLY) {
goto zerob;
}
if (c == 'o' || c == 'O') {
if (under) {
goto endgame;
}
explicitOctal = 1;
state = ZERO_O;
break;
}
if (c == 'd' || c == 'D') {
if (under) {
goto endgame;
}
state = ZERO_D;
break;
}
#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_O:
zeroo:
if (c == '0') {
numTrailZeros++;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
| > > | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_O:
zeroo:
if (c == '0') {
numTrailZeros++;
under = 0;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
under = 0;
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = OCTAL;
break;
}
/* FALLTHROUGH */
case BAD_OCTAL:
if (explicitOctal) {
/*
* No forgiveness for bad digits in explicitly octal numbers.
| > > > > | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = OCTAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
/* FALLTHROUGH */
case BAD_OCTAL:
if (explicitOctal) {
/*
* No forgiveness for bad digits in explicitly octal numbers.
|
| ︙ | ︙ | |||
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 |
* Scanned a number with a leading zero that contains an 8, 9,
* radix point or E. This is an invalid octal number, but might
* still be floating point.
*/
if (c == '0') {
numTrailZeros++;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += (numTrailZeros + 1);
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = BAD_OCTAL;
break;
} else if (c == '.') {
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
state = EXPONENT_START;
break;
}
#endif
goto endgame;
/*
| > > > > | 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 |
* Scanned a number with a leading zero that contains an 8, 9,
* radix point or E. This is an invalid octal number, but might
* still be floating point.
*/
if (c == '0') {
numTrailZeros++;
under = 0;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += (numTrailZeros + 1);
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
under = 0;
state = BAD_OCTAL;
break;
} else if (c == '.') {
under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
under = 0;
state = EXPONENT_START;
break;
}
#endif
goto endgame;
/*
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
acceptLen = len;
/* FALLTHROUGH */
case ZERO_X:
zerox:
if (c == '0') {
numTrailZeros++;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
d = (c-'a'+10);
} else {
goto endgame;
}
if (objPtr != NULL) {
shift = 4 * (numTrailZeros + 1);
if (!significandOverflow) {
/*
| > > > > > > > > | 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 |
acceptLen = len;
/* FALLTHROUGH */
case ZERO_X:
zerox:
if (c == '0') {
numTrailZeros++;
under = 0;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
under = 0;
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
under = 0;
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
under = 0;
d = (c-'a'+10);
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else {
goto endgame;
}
if (objPtr != NULL) {
shift = 4 * (numTrailZeros + 1);
if (!significandOverflow) {
/*
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 |
acceptPoint = p;
acceptLen = len;
/* FALLTHRU */
case ZERO_B:
zerob:
if (c == '0') {
numTrailZeros++;
state = BINARY;
break;
} else if (c != '1') {
goto endgame;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
if (!significandOverflow) {
/*
| > > > > > | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 |
acceptPoint = p;
acceptLen = len;
/* FALLTHRU */
case ZERO_B:
zerob:
if (c == '0') {
numTrailZeros++;
under = 0;
state = BINARY;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (c != '1') {
goto endgame;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
if (!significandOverflow) {
/*
|
| ︙ | ︙ | |||
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 |
}
numTrailZeros = 0;
state = BINARY;
break;
case ZERO_D:
if (c == '0') {
numTrailZeros++;
} else if ( ! isdigit(UCHAR(c))) {
goto endgame;
}
state = DECIMAL;
flags |= TCL_PARSE_INTEGER_ONLY;
/* FALLTHROUGH */
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '0') {
numTrailZeros++;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c - '0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
state = DECIMAL;
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
state = EXPONENT_START;
break;
}
goto endgame;
/*
* Found a decimal point. If no digits have yet been scanned, E is
| > > > > > > > > > > > > > > > | 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 |
}
numTrailZeros = 0;
state = BINARY;
break;
case ZERO_D:
if (c == '0') {
under = 0;
numTrailZeros++;
} else if ( ! isdigit(UCHAR(c))) {
if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
}
under = 0;
state = DECIMAL;
flags |= TCL_PARSE_INTEGER_ONLY;
/* FALLTHROUGH */
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '0') {
numTrailZeros++;
under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c - '0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
under = 0;
state = DECIMAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
under = 0;
state = EXPONENT_START;
break;
}
goto endgame;
/*
* Found a decimal point. If no digits have yet been scanned, E is
|
| ︙ | ︙ | |||
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 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = FRACTION;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
state = EXPONENT;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
state = EXPONENT;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | > | | 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 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
under = 0;
state = FRACTION;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
under = 0;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
under = 0;
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
under = 0;
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
under = 0;
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
under = 0;
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
under = 0;
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
under = 0;
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
under = 0;
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
under = 0;
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
under = 0;
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
under = 0;
break;
}
if (numSigDigs < 13) {
if (c >= '0' && c <= '9') {
d = c - '0';
} else if (c >= 'a' && c <= 'f') {
d = 10 + c - 'a';
} else if (c >= 'A' && c <= 'F') {
d = 10 + c - 'A';
} else {
goto endgame;
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
under = 0;
state = sNANHEX;
break;
}
goto endgame;
case sNANFINISH:
#endif
case sINFINITY:
acceptState = state;
acceptPoint = p;
acceptLen = len;
goto endgame;
}
p++;
len--;
}
endgame:
if (acceptState == INITIAL) {
/*
* No numeric string at all found.
*/
status = TCL_ERROR;
if (endPtrPtr != NULL) {
*endPtrPtr = p;
}
} else {
/*
* Back up to the last accepting state in the lexer.
* If the last char seen is the numeric whitespace character '_',
* backup to that.
*/
p = under ? acceptPoint-1 : acceptPoint;
len = under ? acceptLen-1 : acceptLen;
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
*/
while (len != 0 && TclIsSpaceProcM(*p)) {
p++;
len--;
}
}
if (endPtrPtr == NULL) {
if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) {
status = TCL_ERROR;
|
| ︙ | ︙ | |||
2159 2160 2161 2162 2163 2164 2165 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
| | | | | | 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) {
w >>= 32; rv += 32;
}
if (!(w & (Tcl_WideUInt) 0xFFFF)) {
w >>= 16; rv += 16;
}
if (!(w & (Tcl_WideUInt) 0xFF)) {
w >>= 8; rv += 8;
}
if (!(w & (Tcl_WideUInt) 0xF)) {
w >>= 4; rv += 4;
}
if (!(w & 0x3)) {
w >>= 2; rv += 2;
}
if (!(w & 0x1)) {
w >>= 1; ++rv;
|
| ︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
| | | | | | | 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 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) {
wi = (unsigned long) (w >> 32); rv = 32;
} else {
wi = (unsigned long) w; rv = 0;
}
if (wi & 0xFFFF0000) {
wi >>= 16; rv += 16;
}
if (wi & 0xFF00) {
wi >>= 8; rv += 8;
}
if (wi & 0xF0) {
wi >>= 4; rv += 4;
}
if (wi & 0xC) {
wi >>= 2; rv += 2;
}
if (wi & 0x2) {
wi >>= 1; ++rv;
}
if (wi & 0x1) {
++rv;
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 |
int *decpt, /* Decimal point to set to a bogus value. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval;
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
| | | | 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 |
int *decpt, /* Decimal point to set to a bogus value. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval;
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
retval = (char *)ckalloc(9);
strcpy(retval, "Infinity");
if (endPtr) {
*endPtr = retval + 8;
}
} else {
retval = (char *)ckalloc(4);
strcpy(retval, "NaN");
if (endPtr) {
*endPtr = retval + 3;
}
}
return retval;
}
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
| | | 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval = (char *)ckalloc(2);
strcpy(retval, "0");
if (endPtr) {
*endPtr = retval+1;
}
*decpt = 0;
return retval;
|
| ︙ | ︙ | |||
2654 2655 2656 2657 2658 2659 2660 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
| | | | 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 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
ds = tens[k & 0xF];
j = k >> 4;
if (j & BLETCH) {
j &= (BLETCH-1);
d /= bigtens[N_BIGTENS - 1];
ieps++;
}
i = 0;
for (; j != 0; j>>=1) {
if (j & 1) {
ds *= bigtens[i];
++ieps;
}
++i;
}
d /= ds;
} else if ((j1 = -k) != 0) {
/*
* The number must be increased to bring it into range.
*/
d *= tens[j1 & 0xF];
i = 0;
for (j = j1>>4; j; j>>=1) {
if (j & 1) {
ieps++;
d *= bigtens[i];
}
++i;
|
| ︙ | ︙ | |||
2900 2901 2902 2903 2904 2905 2906 |
if (k_check && d < 1. && ilim > 0) {
if (ilim1 < 0) {
return NULL;
}
ilim = ilim1;
--k;
| | | | | 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 |
if (k_check && d < 1. && ilim > 0) {
if (ilim1 < 0) {
return NULL;
}
ilim = ilim1;
--k;
d = d * 10.0;
++ieps;
}
/*
* Compute estimated roundoff error.
*/
eps.d = ieps * d + 7.;
eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT;
/*
* Handle the peculiar case where the result has no significant digits.
*/
retval = (char *)ckalloc(len + 1);
if (ilim == 0) {
d = d - 5.;
if (d > eps.d) {
*retval = '1';
*decpt = k;
return retval;
} else if (d < -eps.d) {
*decpt = k;
return retval;
|
| ︙ | ︙ | |||
3026 3027 3028 3029 3030 3031 3032 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
| | | 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 | * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ static inline char * StrictInt64Conversion( | < | | 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 |
* of the terminal null byte in '*endPtr'.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictInt64Conversion(
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int s2, int s5, /* Scale factors for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
| | | 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
mp_int mplus, mminus; /* Bounds for roundoff. */
mp_digit digit; /* Current output digit. */
char *s = retval; /* Cursor in the output buffer. */
int i; /* Index in the output buffer. */
|
| ︙ | ︙ | |||
3584 3585 3586 3587 3588 3589 3590 | * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ static inline char * StrictBignumConversionPowD( | < | | 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 |
* of the terminal null byte in '*endPtr'.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversionPowD(
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int sd, /* Scale factor for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
mp_digit digit; /* Current output digit. */
char *s = retval; /* Cursor in the output buffer. */
int i; /* Index in the output buffer. */
mp_err err;
|
| ︙ | ︙ | |||
3798 3799 3800 3801 3802 3803 3804 |
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
| | | 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 |
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int mminus; /* 1/2 ulp below the result. */
mp_int mplus; /* 1/2 ulp above the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
|
| ︙ | ︙ | |||
4022 4023 4024 4025 4026 4027 4028 | * to the end of the number in *endPtr. * *---------------------------------------------------------------------- */ static inline char * StrictBignumConversion( | < | | 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 |
* to the end of the number in *endPtr.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversion(
Tcl_WideUInt bw, /* Integer significand and exponent. */
int b2, /* Scale factor for the significand. */
int s2, int s5, /* Scale factors for denominator. */
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
int g; /* Size of the current digit ground. */
|
| ︙ | ︙ | |||
4462 4463 4464 4465 4466 4467 4468 | /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. */ | | | | | 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 |
/*
* If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
* then all our intermediate calculations can be done using exact
* 64-bit arithmetic with no need for expensive multiprecision
* operations.
*/
return StrictInt64Conversion(bw, b2, b5, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
* The denominator is a power of 2, so we can replace division by
* digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT,
* and adjust m2 and b2 accordingly. Then we launch into a version
* of the comparison that's specialized for the 'power of mp_digit
* in the denominator' case.
*/
if (s2 % MP_DIGIT_BIT != 0) {
int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
s2 += delta;
}
return StrictBignumConversionPowD(bw, b2, b5,
s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
* There are no helpful special cases, but at least we know in
* advance how many digits we will convert. We can run the
* conversion in steps of DIGIT_GROUP digits, so as to have many
* fewer mp_int divisions.
*/
return StrictBignumConversion(bw, b2, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4622 4623 4624 4625 4626 4627 4628 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
| | | | 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
if ((bitwhack.iv >> 32) == 0x3FF00000) {
n770_fp = 0;
} else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) {
n770_fp = 1;
} else {
Tcl_Panic("unknown floating point word order on this machine");
}
#endif
}
|
| ︙ | ︙ | |||
5078 5079 5080 5081 5082 5083 5084 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
| | | | 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 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
retval = frexp(retval * pow10vals[exponent & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
retval = frexp(retval * pow_10_2_n[i], &j);
expt += j;
}
}
} else if (exponent < 0) {
/*
* Divide by 10**-exponent.
*/
retval = frexp(retval / pow10vals[(-exponent) & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if ((-exponent) & (1<<i)) {
retval = frexp(retval / pow_10_2_n[i], &j);
expt += j;
}
}
|
| ︙ | ︙ | |||
5207 5208 5209 5210 5211 5212 5213 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
| | | 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
return (((w >> 32) & 0xFFFFFFFF) | (w << 32));
}
#endif
/*
*----------------------------------------------------------------------
*
* TclNokia770Doubles --
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | * * To allow many appends to be done to an object without constantly * reallocating the space for the string or Unicode representation, we * allocate double the space for the string or Unicode and use the * internal representation to keep track of how much space is used vs. * allocated. * | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | * * To allow many appends to be done to an object without constantly * reallocating the space for the string or Unicode representation, we * allocate double the space for the string or Unicode and use the * internal representation to keep track of how much space is used vs. * allocated. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 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" #include "tclTomMath.h" |
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
if (needed <= INT_MAX / 2) {
attempt = 2 * needed;
| | | | | 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 |
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
if (needed <= INT_MAX / 2) {
attempt = 2 * needed;
ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
unsigned int limit = INT_MAX - needed;
unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1);
}
}
if (ptr == NULL) {
/*
* First allocation - just big enough; or last chance fallback.
*/
attempt = needed;
ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1);
}
objPtr->bytes = ptr;
stringPtr->allocated = attempt;
}
static void
GrowUnicodeBuffer(
|
| ︙ | ︙ | |||
338 339 340 341 342 343 344 |
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
| | < | < | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewStringObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
877 878 879 880 881 882 883 |
* Change length of an existing string rep.
*/
if (length > stringPtr->allocated) {
/*
* Need to enlarge the buffer.
*/
if (objPtr->bytes == &tclEmptyString) {
| | | | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 |
* Change length of an existing string rep.
*/
if (length > stringPtr->allocated) {
/*
* Need to enlarge the buffer.
*/
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = (char *)ckalloc(length + 1);
} else {
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1);
}
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
|
| ︙ | ︙ | |||
983 984 985 986 987 988 989 |
/*
* Need to enlarge the buffer.
*/
char *newBytes;
if (objPtr->bytes == &tclEmptyString) {
| | | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 |
/*
* Need to enlarge the buffer.
*/
char *newBytes;
if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)attemptckalloc(length + 1);
} else {
newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1);
}
if (newBytes == NULL) {
return 0;
}
objPtr->bytes = newBytes;
stringPtr->allocated = length;
}
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
* at "bytes" were appended. */
{
String *stringPtr;
int toCopy = 0;
| | < < < > > > > > > > | | > > > > | | | 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 |
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
* at "bytes" were appended. */
{
String *stringPtr;
int toCopy = 0;
int eLen = 0;
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
}
if (length == 0) {
return;
}
if (limit <= 0) {
return;
}
if (length <= limit) {
toCopy = length;
} else {
if (ellipsis == NULL) {
ellipsis = "...";
}
eLen = strlen(ellipsis);
while (eLen > limit) {
eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
}
toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes;
}
/*
* If objPtr has a valid Unicode rep, then append the Unicode conversion
* of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
* objPtr's string rep.
*/
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
}
if (length <= limit) {
return;
}
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
AppendUtfToUtfRep(objPtr, ellipsis, eLen);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendToObj --
|
| ︙ | ︙ | |||
2123 2124 2125 2126 2127 2128 2129 |
isNegative = (s < (short) 0);
if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
if (l == (long) 0) gotHash = 0;
}
| | | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 |
isNegative = (s < (short) 0);
if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
if (l == (long) 0) gotHash = 0;
}
TclNewObj(segment);
allocSegment = 1;
segmentLimit = INT_MAX;
Tcl_IncrRefCount(segment);
if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
Tcl_AppendToObj(segment,
(isNegative ? "-" : gotPlus ? "+" : " "), 1);
|
| ︙ | ︙ | |||
2168 2169 2170 2171 2172 2173 2174 |
switch (ch) {
case 'd': {
int length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
| | | | | 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 |
switch (ch) {
case 'd': {
int length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
TclNewIntObj(pure, w);
#endif
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
/*
* Already did the sign above.
*/
|
| ︙ | ︙ | |||
2298 2299 2300 2301 2302 2303 2304 |
/*
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
| | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 |
/*
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
TclNewObj(pure);
Tcl_SetObjLength(pure, (int) numDigits);
bytes = TclGetString(pure);
toAppend = length = (int) numDigits;
while (numDigits--) {
int digitOffset;
if (useBig && !mp_iszero(&big)) {
|
| ︙ | ︙ | |||
2419 2420 2421 2422 2423 2424 2425 | /* * Don't pass length modifiers! */ *p++ = (char) ch; *p = '\0'; | | | | | | | 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 |
/*
* Don't pass length modifiers!
*/
*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, sprintf(bytes, spec, d))) {
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));
|
| ︙ | ︙ | |||
2533 2534 2535 2536 2537 2538 2539 |
Tcl_Format(
Tcl_Interp *interp,
const char *format,
int objc,
Tcl_Obj *const objv[])
{
int result;
| | > | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 |
Tcl_Format(
Tcl_Interp *interp,
const char *format,
int objc,
Tcl_Obj *const objv[])
{
int result;
Tcl_Obj *objPtr;
TclNewObj(objPtr);
result = Tcl_AppendFormatToObj(interp, objPtr, format, objc, objv);
if (result != TCL_OK) {
Tcl_DecrRefCount(objPtr);
return NULL;
}
return objPtr;
}
|
| ︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 |
static void
AppendPrintfToObjVA(
Tcl_Obj *objPtr,
const char *format,
va_list argList)
{
int code, objc;
| | > | 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 |
static void
AppendPrintfToObjVA(
Tcl_Obj *objPtr,
const char *format,
va_list argList)
{
int code, objc;
Tcl_Obj **objv, *list;
const char *p;
TclNewObj(list);
p = format;
Tcl_IncrRefCount(list);
while (*p != '\0') {
int size = 0, seekingConversion = 1, gotPrecision = 0;
int lastNum = -1;
if (*p++ != '%') {
|
| ︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 | /* * Within that buffer, we trim both ends if needed so that we * copy only whole characters, and avoid copying any partial * multi-byte characters. */ | | | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 |
/*
* Within that buffer, we trim both ends if needed so that we
* copy only whole characters, and avoid copying any partial
* multi-byte characters.
*/
q = TclUtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
end = q;
}
q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
|
| ︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 |
Tcl_Obj *
Tcl_ObjPrintf(
const char *format,
...)
{
va_list argList;
| | > | 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 |
Tcl_Obj *
Tcl_ObjPrintf(
const char *format,
...)
{
va_list argList;
Tcl_Obj *objPtr;
TclNewObj(objPtr);
va_start(argList, format);
AppendPrintfToObjVA(objPtr, format, argList);
va_end(argList);
return objPtr;
}
/*
|
| ︙ | ︙ | |||
3304 3305 3306 3307 3308 3309 3310 |
return NULL;
}
dst = Tcl_GetString(objResultPtr) + start;
/* assert ( length > start ) */
TclFreeIntRep(objResultPtr);
} else {
| | | 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 |
return NULL;
}
dst = Tcl_GetString(objResultPtr) + start;
/* assert ( length > start ) */
TclFreeIntRep(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 %u bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
|
| ︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 |
* memcmp. In benchmark testing this proved the most efficient
* check between the unicode and string comparison operations.
*/
if (nocase) {
s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len);
s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
| | | 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 |
* memcmp. In benchmark testing this proved the most efficient
* check between the unicode and string comparison operations.
*/
if (nocase) {
s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len);
s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcasecmp;
} else {
s1len = Tcl_GetCharLength(value1Ptr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == value1Ptr->length)
&& (value1Ptr->bytes != NULL)
&& (s2len == value2Ptr->length)
&& (value2Ptr->bytes != NULL)) {
|
| ︙ | ︙ | |||
3425 3426 3427 3428 3429 3430 3431 |
checkEq
#endif
) {
memCmpFn = memcmp;
s1len *= sizeof(Tcl_UniChar);
s2len *= sizeof(Tcl_UniChar);
} else {
| | | 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 |
checkEq
#endif
) {
memCmpFn = memcmp;
s1len *= sizeof(Tcl_UniChar);
s2len *= sizeof(Tcl_UniChar);
} else {
memCmpFn = (memCmpFn_t)(void *)Tcl_UniCharNcmp;
}
}
}
} else {
empty = TclCheckEmptyString(value1Ptr);
if (empty > 0) {
switch (TclCheckEmptyString(value2Ptr)) {
|
| ︙ | ︙ | |||
3483 3484 3485 3486 3487 3488 3489 |
* memcmp() as that is unsafe with any string containing NUL
* (\xC0\x80 in Tcl's utf rep). We can use the more efficient
* TclpUtfNcmp2 if we are case-sensitive and no specific
* length was requested.
*/
if ((reqlength < 0) && !nocase) {
| | | | 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 |
* memcmp() as that is unsafe with any string containing NUL
* (\xC0\x80 in Tcl's utf rep). We can use the more efficient
* TclpUtfNcmp2 if we are case-sensitive and no specific
* length was requested.
*/
if ((reqlength < 0) && !nocase) {
memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2;
} else {
s1len = Tcl_NumUtfChars(s1, s1len);
s2len = Tcl_NumUtfChars(s2, s2len);
memCmpFn = (memCmpFn_t)(void *)
(nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
}
}
}
length = (s1len < s2len) ? s1len : s2len;
if (reqlength > 0 && reqlength < length) {
|
| ︙ | ︙ | |||
3513 3514 3515 3516 3517 3518 3519 |
match = 1; /* This will be reversed below. */
} else {
/*
* The comparison function should compare up to the minimum byte
* length only.
*/
| | | 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 |
match = 1; /* This will be reversed below. */
} else {
/*
* The comparison function should compare up to the minimum byte
* length only.
*/
match = memCmpFn(s1, s2, length);
}
if ((match == 0) && (reqlength > length)) {
match = s1len - s2len;
}
match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
}
matchdone:
|
| ︙ | ︙ | |||
3542 3543 3544 3545 3546 3547 3548 | * * Side effects: * needle and haystack may have their Tcl_ObjType changed. * *--------------------------------------------------------------------------- */ | < > > > > | | | | | > | < < | < | | | < > | | | | | | > | | > > | < < > > > > | | | > < > < | | | | | | | | | | | | | | > | | | > > | < | 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 |
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int start)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
Tcl_UniChar *checkStr, *endStr, *uh, *un;
if (start < 0) {
start = 0;
}
if (ln == 0) {
/* We don't find empty substrings. Bizarre!
* Whenever this routine is turned into a proper substring
* finder, change to `return start` after limits imposed. */
goto firstEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *end, *check, *bh;
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
/* Find bytes in bytes */
bh = Tcl_GetByteArrayFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
end = bh + lh;
check = bh + start;
while (check + ln <= end) {
/*
* Look for the leading byte of the needle in the haystack
* starting at check and stopping when there's not enough room
* for the needle left.
*/
check = (unsigned char *)memchr(check, bn[0], (end + 1 - ln) - check);
if (check == NULL) {
/* Leading byte not found -> needle cannot be found. */
goto firstEnd;
}
/* Leading byte found, check rest of needle. */
if (0 == memcmp(check+1, bn+1, ln-1)) {
/* Checks! Return the successful index. */
value = (check - bh);
goto firstEnd;
}
/* Rest of needle match failed; Iterate to continue search. */
check++;
}
goto firstEnd;
}
/*
* TODO: It might be nice to support some cases where it is not
* necessary to shimmer to &tclStringType to compute the result,
* and instead operate just on the objPtr->bytes values directly.
* However, we also do not want the answer to change based on the
* code pathway, or if it does we want that to be for some values
* we explicitly decline to support. Getting there will involve
* locking down in practice more firmly just what encodings produce
* what supported results for the objPtr->bytes values. For now,
* do only the well-defined Tcl_UniChar array search.
*/
un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
endStr = uh + lh;
for (checkStr = uh + start; checkStr + ln <= endStr; checkStr++) {
if ((*checkStr == *un) && (0 ==
memcmp(checkStr + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
value = (checkStr - uh);
goto firstEnd;
}
}
firstEnd:
TclNewIntObj(result, value);
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* last instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int last)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
Tcl_UniChar *checkStr, *uh, *un;
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_GetByteArrayFromObj(haystack, &lh);
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
if (last >= lh) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
check = bh + last + 1 - ln;
while (check >= bh) {
if ((*check == bn[0])
&& (0 == memcmp(check+1, bn+1, ln-1))) {
value = (check - bh);
goto lastEnd;
}
check--;
}
goto lastEnd;
}
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
un = Tcl_GetUnicodeFromObj(needle, &ln);
if (last >= lh) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
checkStr = uh + last + 1 - ln;
while (checkStr >= uh) {
if ((*checkStr == un[0])
&& (0 == memcmp(checkStr+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
value = (checkStr - uh);
goto lastEnd;
}
checkStr--;
}
lastEnd:
TclNewIntObj(result, value);
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringReverse --
*
|
| ︙ | ︙ | |||
3812 3813 3814 3815 3816 3817 3818 |
if (objPtr->bytes) {
int numChars = stringPtr->numChars;
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
if (!inPlace || Tcl_IsShared(objPtr)) {
| | | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
if (objPtr->bytes) {
int numChars = stringPtr->numChars;
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
if (!inPlace || Tcl_IsShared(objPtr)) {
TclNewObj(objPtr);
Tcl_SetObjLength(objPtr, numBytes);
}
to = objPtr->bytes;
if (numChars < numBytes) {
/*
* Either numChars == -1 and we don't know how many chars are
|
| ︙ | ︙ | |||
4162 4163 4164 4165 4166 4167 4168 | * representation is set to "String". * *---------------------------------------------------------------------- */ static int SetStringFromAny( | | | 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 |
* representation is set to "String".
*
*----------------------------------------------------------------------
*/
static int
SetStringFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert. */
{
if (!TclHasIntRep(objPtr, &tclStringType)) {
String *stringPtr = stringAlloc(0);
/*
* Convert whatever we have into an untyped value. Just A String.
|
| ︙ | ︙ |
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
int allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
int maxChars; /* Max number of chars that can fit in the
* space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
| | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
int allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
int maxChars; /* Max number of chars that can fit in the
* space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
* of this field depends on the 'maxChars'
* field above. */
} String;
#define STRING_MAXCHARS \
(int)(((size_t)UINT_MAX - 1 - offsetof(String, unicode))/sizeof(Tcl_UniChar))
#define STRING_SIZE(numChars) \
(offsetof(String, unicode) + ((numChars + 1) * sizeof(Tcl_UniChar)))
#define stringCheckLimits(numChars) \
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
(int)STRING_MAXCHARS); \
} \
} while (0)
|
| ︙ | ︙ |
Changes to generic/tclStringTrim.h.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* | > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. * * TODO: Find a reasonable way to guarantee in sync with TclIsSpaceProc() */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* |
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
1 2 3 4 5 | /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. * * 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" #include "tommath_private.h" |
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 | #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS #undef TclStaticPackage #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar #if TCL_UTF_MAX > 3 | > > > | | | | | | | | | | | 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 |
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
#undef TclWinNToHS
#undef TclStaticPackage
#undef Tcl_BackgroundError
#undef TclGuessPackageName
#undef TclGetLoadedPackages
#define TclStaticPackage Tcl_StaticPackage
#undef Tcl_UniCharToUtfDString
#undef Tcl_UtfToUniCharDString
#undef Tcl_UtfToUniChar
#undef Tcl_MacOSXOpenBundleResources
#if TCL_UTF_MAX > 3
static void uniCodePanic(void) {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicode (int *(*)(Tcl_Obj *))(void *)uniCodePanic
# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *))(void *)uniCodePanic
# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
#endif
#define TclBN_mp_add mp_add
#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
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) {
mp_err result;
mp_digit d2;
if ((b | (mp_digit)-1) != (mp_digit)-1) {
return MP_VAL;
}
| | | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) {
mp_err result;
mp_digit d2;
if ((b | (mp_digit)-1) != (mp_digit)-1) {
return MP_VAL;
}
result = mp_div_d(a, (mp_digit)b, c, (d ? &d2 : NULL));
if (d) {
*d = d2;
}
return result;
}
mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
return mp_init_set(a, b);
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 |
# define Tcl_SetIntObj 0
# define Tcl_SetLongObj 0
# define Tcl_NewIntObj 0
# define Tcl_NewLongObj 0
# define Tcl_DbNewLongObj 0
# define Tcl_BackgroundError 0
# define Tcl_FreeResult 0
#else
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
mp_digit d2;
mp_err result = mp_div_d(a, 3, c, &d2);
if (d) {
*d = d2;
}
return result;
}
| > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 |
# define Tcl_SetIntObj 0
# define Tcl_SetLongObj 0
# define Tcl_NewIntObj 0
# define Tcl_NewLongObj 0
# define Tcl_DbNewLongObj 0
# define Tcl_BackgroundError 0
# define Tcl_FreeResult 0
# define Tcl_ChannelSeekProc 0
# define Tcl_ChannelCloseProc 0
# define Tcl_Close 0
# define Tcl_MacOSXOpenBundleResources 0
# define TclGuessPackageName 0
# define TclGetLoadedPackages 0
#else
#define TclGuessPackageName guessPackageName
static int TclGuessPackageName(
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_DString *)) {
return 0;
}
#define TclGetLoadedPackages getLoadedPackages
static int TclGetLoadedPackages(
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. */
{
return TclGetLoadedPackagesEx(interp, targetName, NULL);
}
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
mp_digit d2;
mp_err result = mp_div_d(a, 3, c, &d2);
if (d) {
*d = d2;
}
return result;
}
int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c,
TCL_UNUSED(int) /*fast*/)
{
return TclBN_mp_expt_u32(a, b, c);
}
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
{
return TclBN_mp_to_ubin(a, b, INT_MAX, NULL);
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
}
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
{
if (maxlen < 0) {
return MP_VAL;
}
| | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
}
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
{
if (maxlen < 0) {
return MP_VAL;
}
return TclBN_mp_to_radix(a, str, maxlen, NULL, radix);
}
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
{
Tcl_SetStartupScript(path, NULL);
}
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
{
return 2; /* VER_PLATFORM_WIN32_NT */;
}
#define TclWinResetInterfaces doNothing
#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
#endif /* TCL_NO_DEPRECATED */
#ifdef _WIN32
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
| > > > > > > > > > > | < < < < < < < < < < < < < < | 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 |
{
return 2; /* VER_PLATFORM_WIN32_NT */;
}
#define TclWinResetInterfaces doNothing
#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
#endif /* TCL_NO_DEPRECATED */
#define TclpCreateTempFile_ TclpCreateTempFile
#define TclUnixWaitForFile_ TclUnixWaitForFile
#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess
#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty
#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile
#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile
#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile
#endif
#ifdef _WIN32
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty isatty
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
#endif
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TclWinSetSockOpt winSetSockOpt
static int
TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
{
return setsockopt((int) s, level, optname, optval, optlen);
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 439 440 441 442 |
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
int
TclpGetPid(Tcl_Pid pid)
{
| > > > > > > > > | | 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 |
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
int
TclpGetPid(Tcl_Pid pid)
{
return (int)(size_t)pid;
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#undef Tcl_WinUtfToTChar
char *
Tcl_WinUtfToTChar(
const char *string,
|
| ︙ | ︙ | |||
508 509 510 511 512 513 514 |
static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp
static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
}
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp
static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp
#endif
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp
static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
TclDbDumpActiveObjects, /* 243 */
TclGetNamespaceChildTable, /* 244 */
TclGetNamespaceCommandTable, /* 245 */
TclInitRewriteEnsemble, /* 246 */
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
| | > | | | | | | | | | 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 |
TclDbDumpActiveObjects, /* 243 */
TclGetNamespaceChildTable, /* 244 */
TclGetNamespaceCommandTable, /* 245 */
TclInitRewriteEnsemble, /* 246 */
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
TclSetChildCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
TclGetBytesFromObj, /* 259 */
TclUnusedStubEntry, /* 260 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
|
| ︙ | ︙ | |||
1047 1048 1049 1050 1051 1052 1053 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
| | | | 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 |
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 |
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
| | | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 |
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
Tcl_CreateChild, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
Tcl_DeleteChannelHandler, /* 101 */
Tcl_DeleteCloseHandler, /* 102 */
Tcl_DeleteCommand, /* 103 */
Tcl_DeleteCommandFromToken, /* 104 */
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 |
Tcl_GetChannelOption, /* 157 */
Tcl_GetChannelType, /* 158 */
Tcl_GetCommandInfo, /* 159 */
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
| | | | 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 |
Tcl_GetChannelOption, /* 157 */
Tcl_GetChannelType, /* 158 */
Tcl_GetCommandInfo, /* 159 */
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetParent, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
0, /* 167 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_GetOpenFile, /* 167 */
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetChild, /* 172 */
Tcl_GetStdChannel, /* 173 */
Tcl_GetStringResult, /* 174 */
Tcl_GetVar, /* 175 */
Tcl_GetVar2, /* 176 */
Tcl_GlobalEval, /* 177 */
Tcl_GlobalEvalObj, /* 178 */
Tcl_HideCommand, /* 179 */
|
| ︙ | ︙ |
Changes to generic/tclStubLib.c.
1 2 3 4 5 6 | /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
int exact,
int magic)
{
| | > | | | | | | | 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 |
MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
int exact,
int magic)
{
Interp *iPtr = (Interp *)interp;
const char *actualVersion = NULL;
ClientData pkgData = NULL;
const TclStubs *stubsPtr = iPtr->stubTable;
const char *tclName = (((exact&0xFF00) >= 0x900) ? "tcl" : "Tcl");
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
iPtr->freeProc = 0; /* TCL_STATIC */
return NULL;
}
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
if (exact&1) {
const char *p = version;
int count = 0;
while (*p) {
count += !ISDIGIT(*p++);
}
if (count == 1) {
const char *q = actualVersion;
p = version;
while (*p && (*p == *q)) {
p++; q++;
}
if (*p || ISDIGIT(*q)) {
/* Construct error message */
stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
return NULL;
}
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
if (((exact&0xFF00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
tclStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
1 2 3 4 5 6 7 8 | /* * tclTest.c -- * * This file contains C command functions for a bunch of additional Tcl * commands that are used for testing out Tcl's C interfaces. These * commands are not normally included in Tcl applications; they're only * used for testing. * | | | | | > > > | > < < | 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 |
/*
* tclTest.c --
*
* This file contains C command functions for a bunch of additional Tcl
* commands that are used for testing out Tcl's C interfaces. These
* commands are not normally included in Tcl applications; they're only
* used for testing.
*
* Copyright © 1993-1994 The Regents of the University of California.
* Copyright © 1994-1997 Sun Microsystems, Inc.
* Copyright © 1998-2000 Ajuba Solutions.
* Copyright © 2003 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
#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 "tclOO.h"
#include <math.h>
/*
* Required for Testregexp*Cmd
*/
#include "tclRegexp.h"
/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
/*
* Declare external functions used in Windows tests.
*/
DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | #if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif static void CleanupTestSetassocdataTests( void *clientData, Tcl_Interp *interp); static void CmdDelProc1(void *clientData); static void CmdDelProc2(void *clientData); | | < | < | < < | < < | < | | < | < | < < | < | < < | < | | < < | < < | < | < | < | < | < | < | < | < | < < | < | < < | < < | < < | < < | < | < | < < | < | < < | < < | < | < | < | < | < | < | < | < | < < < < < | | | | < < | < | < | < | < | < | < < | < < | < < | < < | < < | < < | < < | < < | < | < | < | < | < < | < | < | < | < | < < | < < | < | < | < | < < | < < | < < | < < | 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 | #if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif 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 void CmdTraceDeleteProc( void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static void CmdTraceProc(void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static Tcl_CmdProc CreatedCommandProc; static Tcl_CmdProc CreatedCommandProc2; static void DelCallbackProc(void *clientData, Tcl_Interp *interp); static Tcl_CmdProc 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 GetTimesObjCmd; static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; static Tcl_ObjCmdProc NoopObjCmd; static int ObjTraceProc(void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandToken, int objc, Tcl_Obj *const objv[]); static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static Tcl_CmdProc TestasyncCmd; static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; static Tcl_CmdProc TestconcatobjCmd; static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; static Tcl_ObjCmdProc TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingObjCmd; static Tcl_ObjCmdProc TestevalexObjCmd; static Tcl_ObjCmdProc TestevalobjvObjCmd; static Tcl_ObjCmdProc TesteventObjCmd; static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, void *clientData); static Tcl_CmdProc TestexithandlerCmd; static Tcl_CmdProc TestexprlongCmd; static Tcl_ObjCmdProc TestexprlongobjCmd; static Tcl_CmdProc TestexprdoubleCmd; static Tcl_ObjCmdProc TestexprdoubleobjCmd; static Tcl_ObjCmdProc TestexprparserObjCmd; static Tcl_CmdProc TestexprstringCmd; static Tcl_ObjCmdProc TestfileCmd; static Tcl_ObjCmdProc TestfilelinkCmd; static Tcl_CmdProc TestfeventCmd; static Tcl_CmdProc TestgetassocdataCmd; static Tcl_CmdProc TestgetintCmd; static Tcl_CmdProc TestlongsizeCmd; static Tcl_CmdProc TestgetplatformCmd; static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; static Tcl_CmdProc TestexitmainloopCmd; static Tcl_CmdProc TestpanicCmd; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserObjCmd; static Tcl_ObjCmdProc TestparsevarObjCmd; static Tcl_ObjCmdProc TestparsevarnameObjCmd; static Tcl_ObjCmdProc TestpreferstableObjCmd; static Tcl_ObjCmdProc TestprintObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; static Tcl_CmdProc TeststaticpkgCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemObjCmd; static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_ObjCmdProc TestgetencpathObjCmd; static Tcl_ObjCmdProc TestsetencpathObjCmd; static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; |
| ︙ | ︙ | |||
414 415 416 417 418 419 420 | 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; | | | | | | < < | < < | < < | < < | < < | < < | < < | 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_CmdProc 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 TestFindFirstCmd;
static Tcl_ObjCmdProc TestFindLastCmd;
static Tcl_ObjCmdProc TestHashSystemHashCmd;
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
static Tcl_ObjCmdProc TestNRELevels;
static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) || defined(_WIN32)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
| > > | < < < < < > | 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 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
#ifndef TCL_WITH_EXTERNAL_TOMMATH
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
|
| ︙ | ︙ | |||
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 |
Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
| > > > > > > | 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 |
Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(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, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 | * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ | < | | | | 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 |
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestasyncCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
if (argc < 2) {
wrongNumArgs:
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler));
asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(asyncPtr->command, argv[2]);
Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 |
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
| | > | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
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;
}
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 | * * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ | < | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 |
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdinfoCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
| < | | < | | | 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 |
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
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, 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, NULL);
return TCL_OK;
}
static void
CmdDelProc1(
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 | * * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ | < | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtokenCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
|
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | * Side effects: * Creates and deletes a command trace, and tests the invocation of * a procedure by the command trace. * *---------------------------------------------------------------------- */ | < | | 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* Side effects:
* Creates and deletes a command trace, and tests the invocation of
* a procedure by the command trace.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtraceCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
}
static void
CmdTraceProc(
void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
| | | | | < | | | < | | < | | | | | | | | | 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 |
}
static void
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*/,
char *command, /* The command being traced (after
* substitutions). */
TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
TCL_UNUSED(void *),
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
Tcl_DString *bufPtr = (Tcl_DString *) clientData;
int i;
Tcl_DStringAppendElement(bufPtr, command);
Tcl_DStringStartSublist(bufPtr);
for (i = 0; i < argc; i++) {
Tcl_DStringAppendElement(bufPtr, argv[i]);
}
Tcl_DStringEndSublist(bufPtr);
}
static void
CmdTraceDeleteProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*level*/,
TCL_UNUSED(char *) /*command*/,
TCL_UNUSED(Tcl_CmdProc *),
TCL_UNUSED(void *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
/*
* 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);
}
static int
ObjTraceProc(
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;
} else if (!strcmp(word, "Break")) {
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 | * and "value:at:"). * *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( | | | 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
* and "value:at:").
*
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option\"", NULL);
|
| ︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
| | | | | | | | 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 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
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",
NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
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",
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 | * * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ | < | | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestdcallCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, id;
delInterp = Tcl_CreateInterp();
|
| ︙ | ︙ | |||
1627 1628 1629 1630 1631 1632 1633 | * * Side effects: * Creates a command. * *---------------------------------------------------------------------- */ | < | | | | | | | | | | | 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 |
*
* Side effects:
* Creates a command.
*
*----------------------------------------------------------------------
*/
static int
TestdelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *child;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
child = Tcl_GetChild(interp, argv[1]);
if (child == NULL) {
return TCL_ERROR;
}
dPtr = (DelCmd *)ckalloc(sizeof(DelCmd));
dPtr->interp = interp;
dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1);
strcpy(dPtr->deleteCmd, argv[3]);
Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
return TCL_OK;
}
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
}
|
| ︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 | * interpreter. * *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( | | | 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 |
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", NULL);
|
| ︙ | ︙ | |||
1741 1742 1743 1744 1745 1746 1747 | * type - One of 'shortest', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int | | | | < < | | < | 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 |
* type - One of 'shortest', 'e', 'f'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
TestdoubledigitsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char* options[] = {
"shortest",
"e",
"f",
NULL
};
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 | * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ | < | | 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 |
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestdstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int count;
if (argc < 2) {
|
| ︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[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", NULL);
} else if (strcmp(argv[2], "free") == 0) {
| | | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[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", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = (char *)ckalloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
char *s = (char*)ckalloc(100) + 16;
strcpy(s, "This is a specially-allocated string");
Tcl_SetResult(interp, s, SpecialFree);
} else {
|
| ︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 | } /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ | | | < > < | | 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 |
}
/*
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(
char *blockPtr /* Block to free. */
) {
ckfree(blockPtr - 16);
}
/*
*----------------------------------------------------------------------
*
* TestencodingCmd --
*
* This procedure implements the "testencoding" command. It is used
* to test the encoding package.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Load encodings.
*
*----------------------------------------------------------------------
*/
static int
TestencodingObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Encoding encoding;
int index, length;
const char *string;
|
| ︙ | ︙ | |||
1988 1989 1990 1991 1992 1993 1994 |
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
| | | | | 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 |
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
encodingPtr = (TclEncoding*)ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
encodingPtr->toUtfCmd = (char *)ckalloc(length + 1);
memcpy(encodingPtr->toUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1);
memcpy(encodingPtr->fromUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[2], &length);
type.encodingName = string;
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
|
| ︙ | ︙ | |||
2029 2030 2031 2032 2033 2034 2035 |
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
| | | | | 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 |
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
TCL_UNUSED(int) /*flags*/,
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
|
| ︙ | ︙ | |||
2061 2062 2063 2064 2065 2066 2067 |
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(
void *clientData, /* TclEncoding structure. */
| | | | | 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 |
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(
void *clientData, /* TclEncoding structure. */
TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
TCL_UNUSED(int) /*flags*/,
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 |
return TCL_OK;
}
static void
EncodingFreeProc(
void *clientData) /* ClientData associated with type. */
{
| | | 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 |
return TCL_OK;
}
static void
EncodingFreeProc(
void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
ckfree(encodingPtr->toUtfCmd);
ckfree(encodingPtr->fromUtfCmd);
ckfree(encodingPtr);
}
/*
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 | * None. * *---------------------------------------------------------------------- */ static int TestevalexObjCmd( | | | 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, flags;
const char *script;
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 | * None. * *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( | | | 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 | * Manipulates the event queue as directed. * *---------------------------------------------------------------------- */ static int TesteventObjCmd( | | | 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 |
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventObjCmd(
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
};
|
| ︙ | ︙ | |||
2253 2254 2255 2256 2257 2258 2259 |
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], positions,
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 |
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], positions,
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
ev = (TestEvent *)ckalloc(sizeof(TestEvent));
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
ev->command = objv[4];
Tcl_IncrRefCount(ev->command);
ev->tag = objv[2];
Tcl_IncrRefCount(ev->tag);
|
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 |
*
*----------------------------------------------------------------------
*/
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
| | | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 |
*
*----------------------------------------------------------------------
*/
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
TCL_UNUSED(int) /*flags*/)
{
TestEvent *ev = (TestEvent *) event;
Tcl_Interp *interp = ev->interp;
Tcl_Obj *command = ev->command;
int result = Tcl_EvalObjEx(interp, command,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
int retval;
|
| ︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | * None. * *---------------------------------------------------------------------- */ static int TestexithandlerCmd( | | | 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int value;
if (argc != 3) {
|
| ︙ | ︙ | |||
2469 2470 2471 2472 2473 2474 2475 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongCmd( | | | 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2512 2513 2514 2515 2516 2517 2518 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( | | | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
|
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( | | | 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2598 2599 2600 2601 2602 2603 2604 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( | | | 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
{
double exprResult;
char buf[4 + TCL_DOUBLE_SPACE];
int result;
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 | * None. * *---------------------------------------------------------------------- */ static int TestexprstringCmd( | | | 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" expression\"", NULL);
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 | * May create a link on disk. * *---------------------------------------------------------------------- */ static int TestfilelinkCmd( | | | 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 |
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *contents;
if (objc < 2 || objc > 3) {
|
| ︙ | ︙ | |||
2739 2740 2741 2742 2743 2744 2745 | * None. * *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( | | | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *res;
if (argc != 2) {
|
| ︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 | * None. * *---------------------------------------------------------------------- */ static int TestgetplatformCmd( | | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static const char *const platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
|
| ︙ | ︙ | |||
2815 2816 2817 2818 2819 2820 2821 | * * Side effects: * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ | < | | | | | | 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 |
*
* Side effects:
* Deletes one or more interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestinterpdeleteCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Interp *childToDelete;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" path\"", NULL);
return TCL_ERROR;
}
childToDelete = Tcl_GetChild(interp, argv[1]);
if (childToDelete == NULL) {
return TCL_ERROR;
}
Tcl_DeleteInterp(childToDelete);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestlinkCmd --
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 | * Side effects: * Creates and deletes various variable links, plus returns * values of the linked variables. * *---------------------------------------------------------------------- */ | < | | | 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 |
* Side effects:
* Creates and deletes various variable links, plus returns
* values of the linked variables.
*
*----------------------------------------------------------------------
*/
static int
TestlinkCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
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;
|
| ︙ | ︙ | |||
3111 3112 3113 3114 3115 3116 3117 |
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
| | | 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 |
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
|
| ︙ | ︙ | |||
3218 3219 3220 3221 3222 3223 3224 |
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
| | | 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 |
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
|
| ︙ | ︙ | |||
3327 3328 3329 3330 3331 3332 3333 | * Creates, deletes, and invokes variable links. * *---------------------------------------------------------------------- */ static int TestlinkarrayCmd( | | | | 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 |
* Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
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 };
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,
|
| ︙ | ︙ | |||
3360 3361 3362 3363 3364 3365 3366 |
Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 |
Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum LinkOptionEnum) optionIndex) {
case LINK_UPDATE:
for (i=2; i<objc; i++) {
Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
}
return TCL_OK;
case LINK_REMOVE:
for (i=2; i<objc; i++) {
|
| ︙ | ︙ | |||
3445 3446 3447 3448 3449 3450 3451 | * Modifies the current C locale. * *---------------------------------------------------------------------- */ static int TestlocaleCmd( | | < | 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 |
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
const char *locale;
static const char *const optionStrings[] = {
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
static const int lcTypes[] = {
LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
LC_ALL
|
| ︙ | ︙ | |||
3504 3505 3506 3507 3508 3509 3510 | * None. * * Side effects: * Releases storage. * *---------------------------------------------------------------------- */ | | | | 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 |
* None.
*
* Side effects:
* Releases storage.
*
*----------------------------------------------------------------------
*/
static void
CleanupTestSetassocdataTests(
void *clientData, /* Data to be released. */
TCL_UNUSED(Tcl_Interp *))
{
ckfree(clientData);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3532 3533 3534 3535 3536 3537 3538 | * None. * *---------------------------------------------------------------------- */ static int TestparserObjCmd( | | | 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserObjCmd(
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, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3588 3589 3590 3591 3592 3593 3594 | * None. * *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( | | | 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserObjCmd(
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, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3735 3736 3737 3738 3739 3740 3741 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( | | | 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarObjCmd(
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;
if (objc != 2) {
|
| ︙ | ︙ | |||
3776 3777 3778 3779 3780 3781 3782 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( | | | 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
int append, length, dummy;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
3839 3840 3841 3842 3843 3844 3845 | * None. * *---------------------------------------------------------------------- */ static int TestpreferstableObjCmd( | | | | > | 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpreferstableObjCmd(
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3868 3869 3870 3871 3872 3873 3874 | * None. * *---------------------------------------------------------------------- */ static int TestprintObjCmd( | | | 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintObjCmd(
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;
|
| ︙ | ︙ | |||
3907 3908 3909 3910 3911 3912 3913 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestregexpObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, ii, indices, stringLength, match, about;
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",
"-line", "-linestop", "-lineanchor",
"-xflags",
"--", NULL
};
enum optionsEnum {
REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
REGEXP_XFLAGS,
REGEXP_LAST
};
indices = 0;
|
| ︙ | ︙ | |||
3952 3953 3954 3955 3956 3957 3958 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
| | | 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 |
if (name[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum optionsEnum) index) {
case REGEXP_INDICES:
indices = 1;
break;
case REGEXP_NOCASE:
cflags |= REG_ICASE;
break;
case REGEXP_ABOUT:
|
| ︙ | ︙ | |||
4231 4232 4233 4234 4235 4236 4237 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestreturnObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 | * data for this interpreter. * *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( | | | | 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 |
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key data_item\"", NULL);
return TCL_ERROR;
}
buf = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | * Sets the tclPlatform global variable. * *---------------------------------------------------------------------- */ static int TestsetplatformCmd( | | | 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
|
| ︙ | ︙ | |||
4362 4363 4364 4365 4366 4367 4368 | * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( | | | 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 |
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
|
| ︙ | ︙ | |||
4413 4414 4415 4416 4417 4418 4419 | * None. * *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( | | | 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
const char *result;
|
| ︙ | ︙ | |||
4452 4453 4454 4455 4456 4457 4458 | * * Side effects: * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ | < | | 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 |
*
* Side effects:
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
static int
TestupvarCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
|
| ︙ | ︙ | |||
4505 4506 4507 4508 4509 4510 4511 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestseterrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc > 6) {
Tcl_AppendResult(interp, "too many args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
4558 4559 4560 4561 4562 4563 4564 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetobjerrorcodeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_SetObjErrorCode(interp, Tcl_ConcatObj(objc - 1, objv + 1));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4587 4588 4589 4590 4591 4592 4593 | * * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ | < | | 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 |
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestfeventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
4662 4663 4664 4665 4666 4667 4668 | * May exit application. * *---------------------------------------------------------------------- */ static int TestpanicCmd( | | | < < | | | 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 |
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
char *argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
ckfree(argString);
return TCL_OK;
}
static int
TestfileCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
{
int force, i, j, result;
Tcl_Obj *error = NULL;
const char *subcmd;
|
| ︙ | ︙ | |||
4765 4766 4767 4768 4769 4770 4771 | * None. * *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( | | | 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *name, *arg;
int flags = 0;
Tcl_Namespace *namespacePtr;
|
| ︙ | ︙ | |||
4839 4840 4841 4842 4843 4844 4845 | * Allocates and frees memory, sets a variable "a" in the interpreter. * *---------------------------------------------------------------------- */ static int GetTimesObjCmd( | | | | | | | | 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 |
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesObjCmd(
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;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr, **objv;
const char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
ckfree(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
/* free 5000 times */
fprintf(stderr, "free 5000 6 word items\n");
|
| ︙ | ︙ | |||
5018 5019 5020 5021 5022 5023 5024 | * None. * *---------------------------------------------------------------------- */ static int NoopCmd( | | | | | | 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5045 5046 5047 5048 5049 5050 5051 | * None. * *---------------------------------------------------------------------- */ static int NoopObjCmd( | | | | | | 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5070 5071 5072 5073 5074 5075 5076 | * None. * *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( | | | 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststringbytesObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
|
| ︙ | ︙ | |||
5110 5111 5112 5113 5114 5115 5116 | * None. * *---------------------------------------------------------------------- */ static int TestpurebytesobjObjCmd( | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < | 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 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpurebytesobjObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?string?");
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
/*
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
*/
memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep));
if (objc == 2) {
const char *s = Tcl_GetString(objv[1]);
objPtr->length = objv[1]->length;
objPtr->bytes = (char *)ckalloc(objPtr->length + 1);
memcpy(objPtr->bytes, s, objPtr->length);
objPtr->bytes[objPtr->length] = 0;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetbytearraylengthObjCmd --
*
* Testing command 'testsetbytearraylength` used to test the public
* interface routine Tcl_SetByteArrayLength().
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetbytearraylengthObjCmd(
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;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
if (Tcl_IsShared(objv[1])) {
obj = Tcl_DuplicateObj(objv[1]);
} else {
obj = objv[1];
}
Tcl_SetByteArrayLength(obj, n);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestbytestringObjCmd --
*
* 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
TestbytestringObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n = 0;
const char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
p = (const char *)TclGetBytesFromObj(interp, objv[1], &n);
if (p == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
5195 5196 5197 5198 5199 5200 5201 | * * Side effects: * Variables may be set. * *---------------------------------------------------------------------- */ | < | 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 |
*
* Side effects:
* Variables may be set.
*
*----------------------------------------------------------------------
*/
static int
TestsetCmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
|
| ︙ | ︙ | |||
5278 5279 5280 5281 5282 5283 5284 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsaveresultCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Interp* iPtr = (Interp*) interp;
int discard, result, index;
Tcl_SavedResult state;
|
| ︙ | ︙ | |||
5323 5324 5325 5326 5327 5328 5329 |
case RESULT_SMALL:
Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
| | | 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 |
case RESULT_SMALL:
Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
char *buf = (char *)ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
|
| ︙ | ︙ | |||
5388 5389 5390 5391 5392 5393 5394 | * Increments the freeCount. * *---------------------------------------------------------------------- */ static void TestsaveresultFree( | | | 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 |
* Increments the freeCount.
*
*----------------------------------------------------------------------
*/
static void
TestsaveresultFree(
TCL_UNUSED(char *))
{
freeCount++;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5412 5413 5414 5415 5416 5417 5418 | * None. * *---------------------------------------------------------------------- */ static int TestmainthreadCmd( | | | | 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
TCL_UNUSED(const char **) /*argv*/)
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
|
| ︙ | ︙ | |||
5473 5474 5475 5476 5477 5478 5479 | * None. * *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( | | | | | | | | | 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexitmainloopCmd --
*
|
| ︙ | ︙ | |||
5502 5503 5504 5505 5506 5507 5508 | * None. * *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( | | | | | | | < | | 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestChannelCmd --
*
* Implements the Tcl "testchannel" debugging command and its
* subcommands. This is part of the testing environment.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestChannelCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
const char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
|
| ︙ | ︙ | |||
5590 5591 5592 5593 5594 5595 5596 |
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
| < | 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 |
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 = Tcl_NewStringObj(argv[3],-1);
|
| ︙ | ︙ | |||
5645 5646 5647 5648 5649 5650 5651 | Tcl_RegisterChannel(NULL, chan); /* prevent closing */ Tcl_UnregisterChannel(interp, chan); Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ | | | 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 |
Tcl_RegisterChannel(NULL, chan); /* prevent closing */
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
/* Remember the channel in the pool of detached channels */
det = (TestChannel *)ckalloc(sizeof(TestChannel));
det->chan = chan;
det->nextPtr = firstDetached;
firstDetached = det;
return TCL_OK;
}
|
| ︙ | ︙ | |||
5837 5838 5839 5840 5841 5842 5843 |
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)) {
| | | 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 |
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 (argc != 3) {
|
| ︙ | ︙ | |||
5878 5879 5880 5881 5882 5883 5884 |
}
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) {
| | | 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 |
}
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 (argc != 3) {
|
| ︙ | ︙ | |||
5935 5936 5937 5938 5939 5940 5941 |
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) {
| | | 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 |
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)) {
/*
|
| ︙ | ︙ | |||
5997 5998 5999 6000 6001 6002 6003 | * * Side effects: * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ | < | | 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 |
*
* Side effects:
* Creates, deletes and returns channel event handlers.
*
*----------------------------------------------------------------------
*/
static int
TestChannelEventCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
|
| ︙ | ︙ | |||
6043 6044 6045 6046 6047 6048 6049 |
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
| | | 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 |
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
|
| ︙ | ︙ | |||
6210 6211 6212 6213 6214 6215 6216 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestSocketCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
{
const char *cmdName; /* Sub command. */
size_t len; /* Length of subcommand string. */
|
| ︙ | ︙ | |||
6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 |
"testflags", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 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 |
"testflags", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestServiceModeCmd --
*
* This procedure implements the "testservicemode" command which gets or
* sets the current Tcl ServiceMode. There are several tests which open
* a file and assign various handlers to it. For these tests to be
* deterministic it is important that file events not be processed until
* all of the handlers are in place.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May change the ServiceMode setting.
*
*----------------------------------------------------------------------
*/
static int
TestServiceModeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int newmode, oldmode;
if (argc > 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" ?newmode?\"", NULL);
return TCL_ERROR;
}
oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE);
if (argc == 2) {
if (Tcl_GetInt(interp, argv[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_NewIntObj(oldmode));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
const char *msg;
|
| ︙ | ︙ | |||
6336 6337 6338 6339 6340 6341 6342 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( | | | 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(
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", "e", "f", NULL, NULL
};
|
| ︙ | ︙ | |||
6390 6391 6392 6393 6394 6395 6396 | * Inserts or removes a filesystem from Tcl's stack. * *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( | | | 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 |
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6469 6470 6471 6472 6473 6474 6475 |
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
| | < < < < < | 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 |
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
static void *
TestReportDupInternalRep(
void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
Tcl_IncrRefCount(original);
return clientData;
}
static void
TestReport(
const char *cmd,
Tcl_Obj *path,
Tcl_Obj *arg2)
{
Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
|
| ︙ | ︙ | |||
6726 6727 6728 6729 6730 6731 6732 |
{
TestReport("utime", fileName, NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(
| | | | 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 |
{
TestReport("utime", fileName, NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
TCL_UNUSED(void **))
{
const char *str = Tcl_GetString(pathPtr);
if (strncmp(str, "simplefs:/", 10)) {
return -1;
}
return TCL_OK;
|
| ︙ | ︙ | |||
6766 6767 6768 6769 6770 6771 6772 | * 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 TestSimpleFilesystemObjCmd( | | | 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 |
* 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
TestSimpleFilesystemObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > | > > > > | | | 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 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 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 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check operations of Tcl_UtfNext.
*
* Usage: testutfnext -bytestring $bytes
*/
static int
TestUtfNextCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int numBytes;
char *bytes;
const char *result, *first;
char buffer[32];
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (numBytes > (int)sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %d bytes",
(int)sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
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]", 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);
if (first != result) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Tcl_UtfNext is not supposed to read src[end]\n"
"Different result when src[end] is %#x", UCHAR(p[-1])));
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
return TCL_OK;
}
/*
* Used to check operations of Tcl_UtfPrev.
*
* Usage: testutfprev $bytes $offset
*/
static int
TestUtfPrevCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int numBytes, offset;
char *bytes;
const char *result;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
if (offset > numBytes) {
offset = numBytes;
}
} else {
offset = numBytes;
}
result = TclUtfPrev(bytes + offset, bytes);
Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes));
return TCL_OK;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int numBytes, len, limit = -1;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
limit = numBytes + 1;
}
}
len = Tcl_NumUtfChars(bytes, limit);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
static int
TestFindFirstCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
6971 6972 6973 6974 6975 6976 6977 | /* * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( | | | 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 |
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
static int
TestFindLastCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
7013 7014 7015 7016 7017 7018 7019 | * None. * *---------------------------------------------------------------------- */ static int TestcpuidCmd( | | | 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestcpuidCmd(
TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
int regs[4];
Tcl_Obj *regsObjs[4];
|
| ︙ | ︙ | |||
7049 7050 7051 7052 7053 7054 7055 | /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ static int TestHashSystemHashCmd( | | | 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 |
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
*/
static int
TestHashSystemHashCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const Tcl_HashKeyType hkType = {
TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
NULL, NULL, NULL, NULL
|
| ︙ | ︙ | |||
7125 7126 7127 7128 7129 7130 7131 | /* * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( | | | 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 |
/*
* 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 argc,
const char **argv)
{
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
7152 7153 7154 7155 7156 7157 7158 | } /* * Used for determining sizeof(long) at script level. */ static int TestlongsizeCmd( | | | | | 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 |
}
/*
* Used for determining sizeof(long) at script level.
*/
static int
TestlongsizeCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int argc,
TCL_UNUSED(const char **) /*argv*/)
{
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long)));
return TCL_OK;
}
static int
NREUnwind_callback(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
int none;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
INT2PTR(-1), NULL);
} else if (data[1] == INT2PTR(-1)) {
|
| ︙ | ︙ | |||
7194 7195 7196 7197 7198 7199 7200 |
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
| | | | | | | | 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 |
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 *),
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
Tcl_Obj *levels[6];
int i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
|
| ︙ | ︙ | |||
7268 7269 7270 7271 7272 7273 7274 | * None. * *---------------------------------------------------------------------- */ static int TestconcatobjCmd( | | | | | 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
int result = TCL_OK, len;
Tcl_Obj *objv[3];
/*
* Set the start of the error message as obj result; it will be cleared at
|
| ︙ | ︙ | |||
7437 7438 7439 7440 7441 7442 7443 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (e) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
| < < | 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (e) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ",
NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
|
| ︙ | ︙ | |||
7469 7470 7471 7472 7473 7474 7475 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (f) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
| < < | 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (f) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ",
NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
|
| ︙ | ︙ | |||
7502 7503 7504 7505 7506 7507 7508 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (g) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
| < < | 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 |
concatPtr = Tcl_ConcatObj(2, objv);
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
"\n\t* (g) concatObj does not have refCount 0", NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ",
NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
|
| ︙ | ︙ | |||
7564 7565 7566 7567 7568 7569 7570 | * None. * *---------------------------------------------------------------------- */ static int TestgetencpathObjCmd( | | | 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetencpathObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
|
| ︙ | ︙ | |||
7597 7598 7599 7600 7601 7602 7603 | * None. * *---------------------------------------------------------------------- */ static int TestsetencpathObjCmd( | | | 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetencpathObjCmd(
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, "defaultDir");
return TCL_ERROR;
|
| ︙ | ︙ | |||
7631 7632 7633 7634 7635 7636 7637 | * None. * *---------------------------------------------------------------------- */ static int TestparseargsCmd( | | | 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 |
* 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;
int count = objc;
Tcl_Obj **remObjv, *result[3];
|
| ︙ | ︙ | |||
7664 7665 7666 7667 7668 7669 7670 |
* Test harness for command and variable resolvers.
*/
static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
| | | | 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 |
* 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;
|
| ︙ | ︙ | |||
7755 7756 7757 7758 7759 7760 7761 |
}
}
return TCL_CONTINUE;
}
static int
InterpVarResolver(
| | | | | | | 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 |
}
}
return TCL_CONTINUE;
}
static int
InterpVarResolver(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_Namespace *),
TCL_UNUSED(int),
TCL_UNUSED(Tcl_Var *))
{
/*
* Don't resolve the variable; use standard rules.
*/
return TCL_CONTINUE;
}
|
| ︙ | ︙ | |||
7848 7849 7850 7851 7852 7853 7854 |
VarHashRefCount(var)++;
return var;
}
static int
InterpCompiledVarResolver(
| | | | | | | | 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 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 |
VarHashRefCount(var)++;
return var;
}
static int
InterpCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *name,
TCL_UNUSED(int) /*length*/,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(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", NULL);
return TCL_ERROR;
}
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
1 2 3 4 5 6 7 8 | /* * tclTestObj.c -- * * This file contains C command functions for the additional Tcl commands * that are used for testing implementations of the Tcl object types. * These commands are not normally included in Tcl applications; they're * only used for testing. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclTestObj.c -- * * This file contains C command functions for the additional Tcl commands * that are used for testing implementations of the Tcl object types. * These commands are not normally included in Tcl applications; they're * only used for testing. * * Copyright © 1995-1998 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * Copyright © 2005 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. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | * Forward declarations for functions defined later in this file: */ static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex); static int GetVariableIndex(Tcl_Interp *interp, const char *string, int *indexPtr); static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr); | | < | < < | < | < | < | | < < | < | | 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 |
* Forward declarations for functions defined later in this file:
*/
static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
const char *string, int *indexPtr);
static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc TestbignumobjCmd;
static Tcl_ObjCmdProc TestbooleanobjCmd;
static Tcl_ObjCmdProc TestdoubleobjCmd;
static Tcl_ObjCmdProc TestindexobjCmd;
static Tcl_ObjCmdProc TestintobjCmd;
static Tcl_ObjCmdProc TestlistobjCmd;
static Tcl_ObjCmdProc TestobjCmd;
static Tcl_ObjCmdProc TeststringobjCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
static void VarPtrDeleteProc(void *clientData, Tcl_Interp *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_DeleteAssocData(interp, VARPTR_KEY);
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 | * type. * *---------------------------------------------------------------------- */ static int TestbignumobjCmd( | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
* type.
*
*----------------------------------------------------------------------
*/
static int
TestbignumobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 | * have boolean type. * *---------------------------------------------------------------------- */ static int TestbooleanobjCmd( | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* have boolean type.
*
*----------------------------------------------------------------------
*/
static int
TestbooleanobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, boolValue;
const char *index, *subCmd;
Tcl_Obj **varPtr;
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | * have double type. * *---------------------------------------------------------------------- */ static int TestdoubleobjCmd( | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
* have double type.
*
*----------------------------------------------------------------------
*/
static int
TestdoubleobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex;
double doubleValue;
const char *index, *subCmd, *string;
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 | * have int type. * *---------------------------------------------------------------------- */ static int TestindexobjCmd( | | > | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 |
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestindexobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
int offset; /* Offset between table entries. */
int index; /* Selected index into table. */
|
| ︙ | ︙ | |||
602 603 604 605 606 607 608 |
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
| | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 |
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = (struct IndexRep *)objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
| | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = (const char **)ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
&index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
|
| ︙ | ︙ | |||
660 661 662 663 664 665 666 | * have int type. * *---------------------------------------------------------------------- */ static int TestintobjCmd( | | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestintobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
Tcl_WideInt wideValue;
const char *index, *subCmd, *string;
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 | * Creates, manipulates and frees list objects. * *----------------------------------------------------------------------------- */ static int TestlistobjCmd( | | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
* Creates, manipulates and frees list objects.
*
*-----------------------------------------------------------------------------
*/
static int
TestlistobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 | * Creates and frees objects. * *---------------------------------------------------------------------- */ static int TestobjCmd( | | | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
* Creates and frees objects.
*
*----------------------------------------------------------------------
*/
static int
TestobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | * have string type. * *---------------------------------------------------------------------- */ static int TeststringobjCmd( | | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 |
* have string type.
*
*----------------------------------------------------------------------
*/
static int
TeststringobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 |
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
| | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* appendself */
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
1 2 3 4 5 6 7 | /* * tclTestProcBodyObj.c -- * * Implements the "procbodytest" package, which contains commands to test * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | /* * tclTestProcBodyObj.c -- * * Implements the "procbodytest" package, which contains commands to test * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. * * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" /* * name and version of this package */ static const char packageName[] = "tcl::procbodytest"; static const char packageVersion[] = "1.1"; /* * Name of the commands exported by this package */ static const char procCommand[] = "proc"; |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
| | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
static int ProcBodyTestProcObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestCheckObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
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
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | }; /* *---------------------------------------------------------------------- * * Procbodytest_Init -- * | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | }; /* *---------------------------------------------------------------------- * * Procbodytest_Init -- * * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. * * Side effects: * None. * |
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | } /* *---------------------------------------------------------------------- * * Procbodytest_SafeInit -- * | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | } /* *---------------------------------------------------------------------- * * Procbodytest_SafeInit -- * * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. * * Side effects: * None. * |
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | * Leaves an error message in the interp's result on error. * *---------------------------------------------------------------------- */ static int ProcBodyTestProcObjCmd( | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
* Leaves an error message in the interp's result on error.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *fullName;
Tcl_Command procCmd;
Command *cmdPtr;
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 | * ProcBodyTestCheckObjCmd -- * * Implements the "procbodytest::check" command. Here is the command * description: * procbodytest::check * * Performs an internal check that the Tcl_PkgPresent() command returns | | | | 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 |
* ProcBodyTestCheckObjCmd --
*
* 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
ProcBodyTestCheckObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *version;
if (objc != 1) {
|
| ︙ | ︙ |
Changes to generic/tclThread.c.
1 2 3 4 5 6 | /* * tclThread.c -- * * This file implements Platform independent thread operations. Most of * the real work is done in the platform dependent files. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclThread.c -- * * This file implements Platform independent thread operations. Most of * the real work is done in the platform dependent files. * * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
122 123 124 125 126 127 128 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | *---------------------------------------------------------------------- * * RememberSyncObject * * Keep a list of (mutexes/condition variable/data key) used during * finalization. * * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the appropriate list. * |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
| | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
newList = (void **)ckalloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
}
}
if (recPtr->list != NULL) {
ckfree(recPtr->list);
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. | | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | /* *---------------------------------------------------------------------- * * ForgetSyncObject * * Remove a single object from the list. * Assume global lock is held. * * Results: * None. * * Side effects: * Remove from the appropriate list. * |
| ︙ | ︙ | |||
215 216 217 218 219 220 221 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | /* *---------------------------------------------------------------------- * * TclRememberMutex * * Keep a list of mutexes used during finalization. * Assume global lock is held. * * Results: * None. * * Side effects: * Add to the mutex list. * |
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
| | | | | 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 |
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpGlobalLock();
ForgetSyncObject(mutexPtr, &mutexRecord);
TclpGlobalUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclRememberCondition
*
* Keep a list of condition variables used during finalization.
* Assume global lock is held.
*
* Results:
* None.
*
* Side effects:
* Add to the condition variable list.
*
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
| | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpGlobalLock();
ForgetSyncObject(condPtr, &condRecord);
TclpGlobalUnlock();
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadData --
*
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 353 354 355 356 357 358 359 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
| > > | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#else
(void)quick;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
| | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
TclpGlobalLock();
#endif
/*
* If we're running unthreaded, the TSD blocks are simply stored inside
* their thread data keys. Free them here.
*/
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
| | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
* Call thread storage global cleanup.
*/
TclFinalizeThreadStorage();
for (i=0 ; i<mutexRecord.num ; i++) {
mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
if (mutexPtr != NULL) {
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
if (condRecord.list != NULL) {
ckfree(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
| | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
if (condRecord.list != NULL) {
ckfree(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
TclpGlobalUnlock();
#endif /* TCL_THREADS */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExitThread --
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
1 2 3 4 5 6 7 8 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright © 1999 America Online, 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" #if TCL_THREADS && defined(USE_THREAD_ALLOC) |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 | */ static Cache * GetCache(void); static void LockBucket(Cache *cachePtr, int bucket); static void UnlockBucket(Cache *cachePtr, int bucket); static void PutBlocks(Cache *cachePtr, int bucket, int numMove); static int GetBlocks(Cache *cachePtr, int bucket); | | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | */ static Cache * GetCache(void); static void LockBucket(Cache *cachePtr, int bucket); static void UnlockBucket(Cache *cachePtr, int bucket); static void PutBlocks(Cache *cachePtr, int bucket, int numMove); static int GetBlocks(Cache *cachePtr, int bucket); static Block * Ptr2Block(void *ptr); static void * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); static void PutObjs(Cache *fromPtr, int numMove); /* * Local variables defined in this file and initialized at startup. */ |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
tcachePtr = GetCache(); \
} \
(cachePtr) = tcachePtr; \
} while (0)
#else
# define GETCACHE(cachePtr) \
do { \
| | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
tcachePtr = GetCache(); \
} \
(cachePtr) = tcachePtr; \
} while (0)
#else
# define GETCACHE(cachePtr) \
do { \
(cachePtr) = (Cache*)TclpGetAllocCache(); \
if ((cachePtr) == NULL) { \
(cachePtr) = GetCache(); \
} \
} while (0)
#endif
/*
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
| | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0);
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
memset(cachePtr, 0, sizeof(Cache));
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
*----------------------------------------------------------------------
*/
void
TclFreeAllocCache(
void *arg)
{
| | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
*----------------------------------------------------------------------
*/
void
TclFreeAllocCache(
void *arg)
{
Cache *cachePtr = (Cache*)arg;
Cache **nextPtrPtr;
unsigned int bucket;
/*
* Flush blocks.
*/
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | * * Side effects: * May allocate more blocks for a bucket. * *---------------------------------------------------------------------- */ | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
*
* Side effects:
* May allocate more blocks for a bucket.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
int bucket;
size_t size;
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
blockPtr = NULL;
size = reqSize + sizeof(Block);
#if RCHECK
size++;
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
| | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
blockPtr = NULL;
size = reqSize + sizeof(Block);
#if RCHECK
size++;
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
blockPtr = (Block *)TclpSysAlloc(size, 0);
if (blockPtr != NULL) {
cachePtr->totalAssigned += reqSize;
}
} else {
bucket = 0;
while (bucketInfo[bucket].blockSize < size) {
bucket++;
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 | * May move blocks to shared cache. * *---------------------------------------------------------------------- */ void TclpFree( | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
* May move blocks to shared cache.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *ptr)
{
Cache *cachePtr;
Block *blockPtr;
int bucket;
if (ptr == NULL) {
return;
|
| ︙ | ︙ | |||
431 432 433 434 435 436 437 | * * Side effects: * Previous memory, if any, may be freed. * *---------------------------------------------------------------------- */ | | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
*
* Side effects:
* Previous memory, if any, may be freed.
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
void *newPtr;
size_t size, min;
int bucket;
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 |
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
cachePtr->buckets[bucket].totalAssigned += reqSize;
return Block2Ptr(blockPtr, bucket, reqSize);
}
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
| | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
cachePtr->buckets[bucket].totalAssigned += reqSize;
return Block2Ptr(blockPtr, bucket, reqSize);
}
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
blockPtr = (Block*)TclpSysRealloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
return Block2Ptr(blockPtr, NBUCKETS, reqSize);
}
/*
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
MoveObjs(sharedPtr, cachePtr, numMove);
}
Tcl_MutexUnlock(objLockPtr);
if (cachePtr->numObjects == 0) {
Tcl_Obj *newObjsPtr;
cachePtr->numObjects = numMove = NOBJALLOC;
| | | | 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 |
MoveObjs(sharedPtr, cachePtr, numMove);
}
Tcl_MutexUnlock(objLockPtr);
if (cachePtr->numObjects == 0) {
Tcl_Obj *newObjsPtr;
cachePtr->numObjects = numMove = NOBJALLOC;
newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
if (newObjsPtr == NULL) {
Tcl_Panic("alloc: could not allocate %d new objects", numMove);
}
cachePtr->lastPtr = newObjsPtr + numMove - 1;
objPtr = cachePtr->firstObjPtr; /* NULL */
while (--numMove >= 0) {
newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr;
objPtr = newObjsPtr + numMove;
}
cachePtr->firstObjPtr = newObjsPtr;
}
}
/*
* Pop the first object.
*/
objPtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 |
/*
* Find the last object to be moved; set the next one (the first one not
* to be moved) as the first object in the 'from' cache.
*/
while (--numMove) {
| | | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 |
/*
* Find the last object to be moved; set the next one (the first one not
* to be moved) as the first object in the 'from' cache.
*/
while (--numMove) {
objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
}
fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
*/
toPtr->lastPtr = objPtr;
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 |
fromPtr->numObjects = keep;
firstPtr = fromPtr->firstObjPtr;
if (keep == 0) {
fromPtr->firstObjPtr = NULL;
} else {
do {
lastPtr = firstPtr;
| | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
fromPtr->numObjects = keep;
firstPtr = fromPtr->firstObjPtr;
if (keep == 0) {
fromPtr->firstObjPtr = NULL;
} else {
do {
lastPtr = firstPtr;
firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1;
} while (--keep > 0);
lastPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 | * * Side effects: * Invalid blocks will abort the server. * *---------------------------------------------------------------------- */ | | | | | 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 |
*
* Side effects:
* Invalid blocks will abort the server.
*
*----------------------------------------------------------------------
*/
static void *
Block2Ptr(
Block *blockPtr,
int bucket,
unsigned int reqSize)
{
void *ptr;
blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
blockPtr->sourceBucket = bucket;
blockPtr->blockReqSize = reqSize;
ptr = ((void *) (blockPtr + 1));
#if RCHECK
((unsigned char *)(ptr))[reqSize] = MAGIC;
#endif
return ptr;
}
static Block *
Ptr2Block(
void *ptr)
{
Block *blockPtr;
blockPtr = (((Block *) ptr) - 1);
if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) {
Tcl_Panic("alloc: invalid block: %p: %x %x",
blockPtr, blockPtr->magicNum1, blockPtr->magicNum2);
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
cachePtr->buckets[bucket].numLocks++;
sharedPtr->buckets[bucket].numLocks++;
}
static void
UnlockBucket(
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
cachePtr->buckets[bucket].numLocks++;
sharedPtr->buckets[bucket].numLocks++;
}
static void
UnlockBucket(
TCL_UNUSED(Cache *),
int bucket)
{
Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | /* * If no blocks could be moved from shared, first look for a larger * block in this cache to split up. */ blockPtr = NULL; n = NBUCKETS; | | | | 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 |
/*
* If no blocks could be moved from shared, first look for a larger
* block in this cache to split up.
*/
blockPtr = NULL;
n = NBUCKETS;
size = 0;
while (--n > bucket) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
cachePtr->buckets[n].numFree--;
break;
}
}
/*
* Otherwise, allocate a big new block directly.
*/
if (blockPtr == NULL) {
size = MAXALLOC;
blockPtr = (Block*)TclpSysAlloc(size, 0);
if (blockPtr == NULL) {
return 0;
}
}
/*
* Split the larger block into smaller blocks for this bucket.
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAllocThread(void)
{
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAllocThread(void)
{
Cache *cachePtr = (Cache *)TclpGetAllocCache();
if (cachePtr != NULL) {
TclpFreeAllocCache(cachePtr);
}
}
#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 | * List appended to given dstring. * *---------------------------------------------------------------------- */ void Tcl_GetMemoryInfo( | | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
* List appended to given dstring.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetMemoryInfo(
TCL_UNUSED(Tcl_DString *))
{
Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclThreadJoin.c.
1 2 3 4 5 6 7 8 | /* * tclThreadJoin.c -- * * This file implements a platform independent emulation layer for the * handling of joinable threads. The Windows platform uses this code to * provide the functionality of joining threads. This code is currently * not necessary on Unix. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclThreadJoin.c -- * * This file implements a platform independent emulation layer for the * handling of joinable threads. The Windows platform uses this code to * provide the functionality of joining threads. This code is currently * not necessary on Unix. * * Copyright © 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 "tclInt.h" |
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
threadPtr->threadMutex = (Tcl_Mutex) NULL;
threadPtr->cond = (Tcl_Condition) NULL;
Tcl_MutexLock(&joinMutex);
|
| ︙ | ︙ |
Changes to generic/tclThreadStorage.c.
1 2 3 4 5 6 | /* * tclThreadStorage.c -- * * This file implements platform independent thread storage operations to * work around system limits on the number of thread-specific variables. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclThreadStorage.c -- * * This file implements platform independent thread storage operations to * work around system limits on the number of thread-specific variables. * * Copyright © 2003-2004 Joe Mistachkin * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | * it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into * the table of TSD values. We don't use more than 1 platform-specific TSD * slot, because there is a hard limit on the number of TSD slots. Valid key * offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey. */ /* | | | | | | | 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 |
* it for storing a table pointer. Each Tcl_ThreadDataKey has an offset into
* the table of TSD values. We don't use more than 1 platform-specific TSD
* slot, because there is a hard limit on the number of TSD slots. Valid key
* offsets are greater than 0; 0 is for the initialized Tcl_ThreadDataKey.
*/
/*
* The global collection of information about TSDs. This is shared across the
* whole process, and includes the mutex used to protect it.
*/
static struct {
void *key; /* Key into the system TSD structure. The
* collection of Tcl TSD values for a
* particular thread will hang off the
* back-end of this. */
sig_atomic_t counter; /* The number of different Tcl TSDs used
* across *all* threads. This is a strictly
* increasing value. */
Tcl_Mutex mutex; /* Protection for the rest of this structure,
* which holds per-process data. */
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
ClientData *tablePtr; /* The table of Tcl TSDs. */
sig_atomic_t allocated; /* The size of the table in the current
* thread. */
} TSDTable;
/*
* The actual type of Tcl_ThreadDataKey.
*/
typedef union {
volatile sig_atomic_t offset;
/* The type is really an offset into the
* thread-local table of TSDs, which is this
* field. */
void *ptr; /* For alignment purposes only. Not actually
* accessed through this. */
} TSDUnion;
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
static TSDTable *
TSDTableCreate(void)
{
TSDTable *tsdTablePtr;
sig_atomic_t i;
| | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
static TSDTable *
TSDTableCreate(void)
{
TSDTable *tsdTablePtr;
sig_atomic_t i;
tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0);
if (tsdTablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
tsdTablePtr->allocated = 8;
tsdTablePtr->tablePtr =
(void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
if (tsdTablePtr->tablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
for (i = 0; i < tsdTablePtr->allocated; ++i) {
tsdTablePtr->tablePtr[i] = NULL;
}
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
static void
TSDTableGrow(
TSDTable *tsdTablePtr,
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
| | | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
static void
TSDTableGrow(
TSDTable *tsdTablePtr,
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
void **newTablePtr;
sig_atomic_t i;
if (newAllocated <= atLeast) {
newAllocated = atLeast + 10;
}
newTablePtr = (void **)TclpSysRealloc(tsdTablePtr->tablePtr,
sizeof(void *) * newAllocated);
if (newTablePtr == NULL) {
Tcl_Panic("unable to reallocate TSDTable");
}
for (i = tsdTablePtr->allocated; i < newAllocated; ++i) {
newTablePtr[i] = NULL;
}
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
| | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
ClientData resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
if ((tsdTablePtr != NULL) && (offset > 0)
&& (offset < tsdTablePtr->allocated)) {
resultPtr = tsdTablePtr->tablePtr[offset];
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
| | | | | | | 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 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
tsdTablePtr = TSDTableCreate();
TclpThreadSetGlobalTSD(tsdGlobal.key, tsdTablePtr);
}
/*
* Get the lock while we check if this TSD is new or not. Note that this
* is the only place where Tcl_ThreadDataKey values are set. We use a
* double-checked lock to try to avoid having to grab this lock a lot,
* since it is on quite a few critical paths and will only get set once in
* each location.
*/
if (keyPtr->offset == 0) {
Tcl_MutexLock(&tsdGlobal.mutex);
if (keyPtr->offset == 0) {
/*
* The Tcl_ThreadDataKey hasn't been used yet. Make a new one.
*/
keyPtr->offset = ++tsdGlobal.counter;
}
Tcl_MutexUnlock(&tsdGlobal.mutex);
}
/*
* Check if this is the first time this Tcl_ThreadDataKey has been used
* with the current thread. Note that we don't need to hold a lock when
* doing this, as we are *definitely* the only point accessing this
* tsdTablePtr right now; it's thread-local.
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
| | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
TclpThreadSetGlobalTSD(tsdGlobal.key, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclInitializeThreadStorage --
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
*
*----------------------------------------------------------------------
*/
void
TclInitThreadStorage(void)
{
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
*
*----------------------------------------------------------------------
*/
void
TclInitThreadStorage(void)
{
tsdGlobal.key = TclpThreadCreateKey();
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadStorage --
*
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadStorage(void)
{
| | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadStorage(void)
{
TclpThreadDeleteKey(tsdGlobal.key);
tsdGlobal.key = NULL;
}
#else /* !TCL_THREADS */
/*
* Stub functions for non-threaded builds
*/
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
1 2 3 4 5 6 7 8 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this should be * tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this should be * tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) | | | | | | | 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 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) static int ThreadObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 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); static Tcl_ThreadCreateType NewTestThread(void *clientData); static void ListRemove(ThreadSpecificData *tsdPtr); static void ListUpdateInner(ThreadSpecificData *tsdPtr); static int ThreadEventProc(Tcl_Event *evPtr, int mask); static void ThreadErrorProc(Tcl_Interp *interp); static void ThreadFreeProc(void *clientData); static int ThreadDeleteEvent(Tcl_Event *eventPtr, void *clientData); static void ThreadExitProc(void *clientData); extern int Tcltest_Init(Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * TclThread_Init -- * |
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < > | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadObjCmd(
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);
int option;
static const char *const threadOptions[] = {
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 | * Possibly -joinable, then no special script, no joinable, then * its a script. */ script = Tcl_GetStringFromObj(objv[2], &len); if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && | | | | 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 |
* Possibly -joinable, then no special script, no joinable, then
* its a script.
*/
script = Tcl_GetStringFromObj(objv[2], &len);
if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
(0 == strncmp(script, "-joinable", len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
/*
* Remember the script
*/
joinable = 0;
}
} else if (objc == 4) {
/*
* Definitely a script available, but is the flag -joinable?
*/
script = Tcl_GetStringFromObj(objv[2], &len);
joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
&& (0 == strncmp(script, "-joinable", len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return ThreadCreate(interp, script, joinable);
}
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
}
case THREAD_EVENT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
| | | | 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 |
return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
}
case THREAD_EVENT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
return TCL_OK;
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
const char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = (char *)ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 | * * Side effects: * Create a thread. * *---------------------------------------------------------------------- */ | < | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
*
* Side effects:
* Create a thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
const char *script, /* Script to execute */
int joinable) /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 | * A Tcl script is executed in a new thread. * *------------------------------------------------------------------------ */ Tcl_ThreadCreateType NewTestThread( | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
* A Tcl script is executed in a new thread.
*
*------------------------------------------------------------------------
*/
Tcl_ThreadCreateType
NewTestThread(
void *clientData)
{
ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
/*
* Initialize the interpreter. This should be more general.
*/
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
| | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
/*
* Notify the parent we are alive.
*/
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
| | | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = (char *)ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = NULL;
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
*
*------------------------------------------------------------------------
*/
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
| | | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 |
*
*------------------------------------------------------------------------
*/
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
TCL_UNUSED(int) /*mask*/)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
const char *result, *errorCode, *errorInfo;
|
| ︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 |
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
| | | | | 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = (char *)ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release(interp);
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | * This is called from when we are exiting and memory needs * to be freed. * * Results: * None. * * Side effects: | | < | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
* This is called from when we are exiting and memory needs
* to be freed.
*
* Results:
* None.
*
* Side effects:
* Clears up mem specified in clientData
*
*------------------------------------------------------------------------
*/
static void
ThreadFreeProc(
void *clientData)
{
if (clientData) {
ckfree(clientData);
}
}
/*
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 | * * Side effects: * It cleans up our events in the event queue for this thread. * *------------------------------------------------------------------------ */ | < | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
*
* Side effects:
* It cleans up our events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
TCL_UNUSED(void *))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
|
| ︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 | * Side effects: * It unblocks anyone that is waiting on a send to this thread. It cleans * up any events in the event queue for this thread. * *------------------------------------------------------------------------ */ | < | | | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 |
* Side effects:
* It unblocks anyone that is waiting on a send to this thread. It cleans
* up any events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
static void
ThreadExitProc(
void *clientData)
{
char *threadEvalScript = (char *)clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->interp != NULL) {
ListRemove(tsdPtr);
}
|
| ︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 | * Dang. The target is going away. Unblock the caller. The result * string must be dynamically allocated because the main thread is * going to call free on it. */ const char *msg = "target thread died"; | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
* Dang. The target is going away. Unblock the caller. The result
* string must be dynamically allocated because the main thread is
* going to call free on it.
*/
const char *msg = "target thread died";
resultPtr->result = (char *)ckalloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
1 2 3 4 5 6 | /* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * * Copyright © 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" |
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
InitTimer(void)
{
| | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
InitTimer(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
}
return tsdPtr;
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | * Removes the timer and idle event sources and remaining events. * *---------------------------------------------------------------------- */ static void TimerExitProc( | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
* Removes the timer and idle event sources and remaining events.
*
*----------------------------------------------------------------------
*/
static void
TimerExitProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
| | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
*/
memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * May update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerSetupProc( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* May update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
|| ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | * May queue an event and update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerCheckProc( | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
* May queue an event and update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
| | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
}
}
/*
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 | * Whatever the timer handler callback functions do. * *---------------------------------------------------------------------- */ static int TimerHandlerEventProc( | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
* Whatever the timer handler callback functions do.
*
*----------------------------------------------------------------------
*/
static int
TimerHandlerEventProc(
TCL_UNUSED(Tcl_Event *),
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
TimerHandler *timerHandlerPtr, **nextPtrPtr;
Tcl_Time time;
int currentTimerId;
ThreadSpecificData *tsdPtr = InitTimer();
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
| | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
idlePtr->nextPtr = NULL;
if (tsdPtr->lastIdlePtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_AfterObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmdsEnum {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
| | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
| | | > | 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 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
case AFTER_INFO:
if (objc == 2) {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
| | > | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, 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;
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
*----------------------------------------------------------------------
*/
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
| | | 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
*----------------------------------------------------------------------
*/
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
AfterInfo *afterPtr = (AfterInfo *)clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
/*
* First remove the callback from our list of callbacks; otherwise someone
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | * * Side effects: * After commands are removed. * *---------------------------------------------------------------------- */ | < | | | 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 |
*
* Side effects:
* After commands are removed.
*
*----------------------------------------------------------------------
*/
static void
AfterCleanupProc(
ClientData clientData, /* Points to AfterAssocData for the
* interpreter. */
TCL_UNUSED(Tcl_Interp *))
{
AfterAssocData *assocPtr = (AfterAssocData *)clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
afterPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr->nextPtr;
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
|
| ︙ | ︙ |
Changes to generic/tclTomMath.h.
1 2 3 4 | #ifndef BN_TCL_H_ #define BN_TCL_H_ #ifdef MP_NO_STDINT | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 |
#ifndef BN_TCL_H_
#define BN_TCL_H_
#ifdef MP_NO_STDINT
# ifdef HAVE_STDINT_H
# include <stdint.h>
#else
# include "../compat/stdint.h"
# endif
#endif
#if defined(TCL_NO_TOMMATH_H)
typedef size_t mp_digit;
typedef int mp_sign;
# define MP_ZPOS 0 /* positive integer */
# define MP_NEG 1 /* negative */
typedef int mp_ord;
# define MP_LT -1 /* less than */
# define MP_EQ 0 /* equal to */
# define MP_GT 1 /* greater than */
typedef int mp_err;
# define MP_OKAY 0 /* no error */
# define MP_ERR -1 /* unknown error */
# define MP_MEM -2 /* out of mem */
# define MP_VAL -3 /* invalid input */
# define MP_ITER -4 /* maximum iterations reached */
# define MP_BUF -5 /* buffer overflow, supplied buffer too small */
# define MP_WUR /* nothing */
# define mp_iszero(a) ((a)->used == 0)
# define mp_isneg(a) ((a)->sign != 0)
/* the infamous mp_int structure */
# ifndef MP_INT_DECLARED
# define MP_INT_DECLARED
typedef struct mp_int mp_int;
# endif
struct mp_int {
int used, alloc;
mp_sign sign;
mp_digit *dp;
};
#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
# include "tommath.h"
#endif
#include "tclTomMathDecls.h"
#endif
|
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | #define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize) #define MP_FREE(mem, size) TclBNFree(mem) #ifndef MODULE_SCOPE # define MODULE_SCOPE extern #endif MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c); MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b); MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b); MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c); MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b); MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b); MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); | > > > > | > | 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 |
#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
#define MP_FREE(mem, size) TclBNFree(mem)
#ifndef MODULE_SCOPE
# define MODULE_SCOPE extern
#endif
#ifdef __cplusplus
extern "C" {
#endif
MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c);
MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b);
MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c);
MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c);
MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c);
#ifdef __cplusplus
}
#endif
/* Rename the global symbols in libtommath to avoid linkage conflicts */
#ifndef TCL_WITH_EXTERNAL_TOMMATH
#define bn_reverse TclBN_reverse
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_s_mp_add_d
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 | #define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b)) #define mp_init_l(a,b) mp_init_i64((a),(long)(b)) #define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b)) #define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b)) #undef mp_iseven #undef mp_isodd #define mp_iseven(a) (!mp_isodd(a)) | | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 | #define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b)) #define mp_init_l(a,b) mp_init_i64((a),(long)(b)) #define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b)) #define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b)) #undef mp_iseven #undef mp_isodd #define mp_iseven(a) (!mp_isodd(a)) #define mp_isodd(a) (((a)->used != 0) && (((a)->dp[0] & 1) != 0)) #undef mp_sqr #define mp_sqr(a,b) mp_mul(a,a,b) #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ |
Changes to generic/tclTomMathInterface.c.
1 2 3 4 5 6 7 8 | /* *---------------------------------------------------------------------- * * tclTomMathInterface.c -- * * This file contains procedures that are used as a 'glue' layer between * Tcl and libtommath. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* *---------------------------------------------------------------------- * * tclTomMathInterface.c -- * * This file contains procedures that are used as a 'glue' layer between * Tcl and libtommath. * * Copyright © 2005 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" |
| ︙ | ︙ |
Changes to generic/tclTomMathStubLib.c.
1 2 3 4 5 6 | /* * tclTomMathStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclTomMathStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 1998 Paul Duffin. * * 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" |
| ︙ | ︙ |
Changes to generic/tclTrace.c.
1 2 3 4 5 | /* * tclTrace.c -- * * This file contains code to handle most trace management. * | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclTrace.c -- * * This file contains code to handle most trace management. * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2002 ActiveState 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" |
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | * A standard Tcl result. * * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ | < < > | | | 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 |
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*----------------------------------------------------------------------
*/
int
Tcl_TraceObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
const char *name;
const char *flagOps, *p;
#endif
/* Main sub commands to 'trace' */
static const char *const traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
NULL
};
/* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptionsEnum {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
/*
* All sub commands of trace add/remove must take at least one more
* argument. Beyond that we let the subcommand itself control the
* argument structure.
*/
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
TclNewObj(opsList);
Tcl_IncrRefCount(opsList);
flagOps = TclGetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
for (p = flagOps; *p != 0; p++) {
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
| | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
TclNewObj(resultListPtr);
name = Tcl_GetString(objv[2]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *q = ops;
pairObjPtr = Tcl_NewListObj(0, NULL);
if (tvarPtr->flags & TCL_TRACE_READS) {
*q = 'r';
q++;
}
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
| | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
|
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
| | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* In checking the 'flags' field we must remove any extraneous
* flags which may have been temporarily added by various
* pieces of the trace mechanism.
*/
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
| | | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
701 702 703 704 705 706 707 |
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
| | | 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 |
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
| | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 |
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
| | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
904 905 906 907 908 909 910 |
flags |= TCL_TRACE_WRITES;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
| | | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
flags |= TCL_TRACE_WRITES;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
* Search through all of our traces on this variable to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
* Search through all of our traces on this variable to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags
#ifndef TCL_REMOVE_OBSOLETE_TRACES
& ~TCL_TRACE_OLD_STYLE
#endif
)==flags)
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
| | | | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
TclNewObj(resultListPtr);
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr;
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 |
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
| | < | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
{
Command *cmdPtr;
|
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 |
return TCL_ERROR;
}
/*
* Set up trace information.
*/
| | | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 |
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
(TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 |
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *)interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return;
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
/*
* Bug 3484621: up the interp's epoch if this is a BC'ed command
*/
if (cmdPtr->compileProc != NULL) {
| < | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
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++;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1274 1275 1276 1277 1278 1279 1280 | * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ | < | | 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 |
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static void
TraceCommandProc(
ClientData clientData, /* Information about the command trace. */
Tcl_Interp *interp, /* Interpreter containing command. */
const char *oldName, /* Name of command being changed. */
const char *newName, /* New name of command. Empty string or NULL
* means command is being deleted (renamed to
* ""). */
int flags) /* OR-ed bits giving operation and other
* information. */
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)
&& !Tcl_LimitExceeded(interp)) {
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 |
*/
int
TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
| | < | 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 |
*/
int
TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
TCL_UNUSED(int) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
int objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
| | | 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 |
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
if (state == NULL) {
state = Tcl_SaveInterpState(interp, code);
|
| ︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 |
(TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/*
* New style trace.
*/
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
| | | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 |
(TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/*
* New style trace.
*/
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
traceCode = tracePtr->proc(tracePtr->clientData, interp,
curLevel, command, (Tcl_Command) cmdPtr, objc,
objv);
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
| | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
commandCopy = (char *)TclStackAlloc(interp, numChars + 1);
memcpy(commandCopy, command, numChars);
commandCopy[numChars] = '\0';
/*
* Call the trace function then free allocated storage.
*/
|
| ︙ | ︙ | |||
1720 1721 1722 1723 1724 1725 1726 |
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(
ClientData clientData)
{
| | | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 |
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(
ClientData clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
}
/*
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
static int
TraceExecutionProc(
ClientData clientData,
Tcl_Interp *interp,
int level,
const char *command,
| | | | 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
static int
TraceExecutionProc(
ClientData clientData,
Tcl_Interp *interp,
int level,
const char *command,
TCL_UNUSED(Tcl_Command),
int objc,
struct Tcl_Obj *const objv[])
{
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Inside any kind of execution trace callback, we do not allow any
|
| ︙ | ︙ | |||
1848 1849 1850 1851 1852 1853 1854 | Tcl_Obj *resultCode; const char *resultCodeStr; /* * Append result code. */ | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 | Tcl_Obj *resultCode; const char *resultCodeStr; /* * Append result code. */ TclNewIntObj(resultCode, code); resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. */ |
| ︙ | ︙ | |||
1915 1916 1917 1918 1919 1920 1921 |
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
| | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 |
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
unsigned len = strlen(command) + 1;
tcmdPtr->startLevel = level;
tcmdPtr->startCmd = (char *)ckalloc(len);
memcpy(tcmdPtr->startCmd, command, len);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted);
}
}
|
| ︙ | ︙ | |||
1959 1960 1961 1962 1963 1964 1965 | * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static char *
TraceVarProc(
ClientData clientData, /* Information about the variable trace. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable or array. */
const char *name2, /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags) /* OR-ed bits giving operation and other
* information. */
{
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
* We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
* of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
* it is not freed while we still need it.
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)
|
| ︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
| | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
tracePtr = (Trace *)ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
tracePtr->delProc = delProc;
tracePtr->nextPtr = iPtr->tracePtr;
tracePtr->flags = flags;
iPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
| | | 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
data, StringTraceDeleteProc);
}
|
| ︙ | ︙ | |||
2259 2260 2261 2262 2263 2264 2265 |
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const *objv)
{
| | | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 |
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const *objv)
{
StringTraceData *data = (StringTraceData *)clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
int i;
/*
* This is a bit messy because we have to emulate the old trace interface,
* which uses strings for everything.
|
| ︙ | ︙ | |||
2660 2661 2662 2663 2664 2665 2666 |
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
| | | 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 |
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve(tracePtr);
if (state == NULL) {
|
| ︙ | ︙ | |||
2704 2705 2706 2707 2708 2709 2710 |
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
| | | 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 |
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve(tracePtr);
if (state == NULL) {
|
| ︙ | ︙ | |||
2942 2943 2944 2945 2946 2947 2948 |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
| | | 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) 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)) {
break;
|
| ︙ | ︙ | |||
3101 3102 3103 3104 3105 3106 3107 |
/*
* Find the relevant trace, if any, and return its clientData.
*/
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
| | | 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 |
/*
* Find the relevant trace, if any, and return its clientData.
*/
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (prevClientData != NULL) {
for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
|
| ︙ | ︙ | |||
3202 3203 3204 3205 3206 3207 3208 |
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
| | | 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 |
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
result = TraceVarEx(interp, part1, part2, tracePtr);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
3296 3297 3298 3299 3300 3301 3302 |
#endif
tracePtr->flags = tracePtr->flags & flagMask;
hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
| | | 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 |
#endif
tracePtr->flags = tracePtr->flags & flagMask;
hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
tracePtr->nextPtr = (VarTrace *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, tracePtr);
/*
* Mark the variable as traced so we know to call them.
*/
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
1 2 3 4 5 6 7 | /* * tclUniData.c -- * * Declarations of Unicode character information tables. This file is * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclUniData.c -- * * Declarations of Unicode character information tables. This file is * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. * * Copyright © 1998 Scriptics Corporation. * All rights reserved. */ /* * A 16-bit Unicode character is split into two parts in order to index * into the following tables. The lower OFFSET_BITS comprise an offset * into a page of characters. The upper bits comprise the page number. |
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3872, 1344, 3904, 3936,
3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352,
4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672,
1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344,
| | | | | | | | | | | | | | | | | | | 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 |
3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3872, 1344, 3904, 3936,
3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352,
4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672,
1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344,
4992, 5024, 5056, 5088, 5120, 1824, 5152, 5184, 5216, 5248, 5280, 5312,
1344, 5344, 1344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, 5632,
5664, 5696, 5728, 5664, 704, 5760, 224, 224, 224, 224, 5792, 224, 224,
224, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144,
6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, 6528,
6560, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6624, 6656, 4928,
6688, 6720, 6752, 6784, 6816, 4928, 6848, 6880, 6912, 6944, 6976, 7008,
7040, 4928, 4928, 4928, 4928, 4928, 7072, 7104, 7136, 4928, 4928, 4928,
7168, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7200, 7232, 4928, 7264,
7296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6592, 6592, 6592,
6592, 7328, 6592, 7360, 7392, 6592, 6592, 6592, 6592, 6592, 6592, 6592,
6592, 4928, 7424, 7456, 7488, 7520, 4928, 4928, 4928, 7552, 7584, 7616,
7648, 224, 224, 224, 7680, 7712, 7744, 1344, 7776, 7808, 7840, 7840,
704, 7872, 7904, 7936, 1824, 7968, 4928, 4928, 8000, 4928, 4928, 4928,
4928, 4928, 4928, 8032, 8064, 8096, 8128, 3232, 1344, 8160, 4192, 1344,
8192, 8224, 8256, 1344, 1344, 8288, 1344, 4928, 8320, 8352, 8384, 8416,
4928, 8384, 8448, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
| | | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8544, 4928, 8576, 5440, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8608, 8640, 224, 8672, 8704, 1344, 1344, 8736, 8768, 8800, 224,
8832, 8864, 8896, 8928, 8960, 8992, 9024, 1344, 9056, 9088, 9120, 9152,
9184, 1632, 9216, 9248, 8480, 1952, 9280, 9312, 9344, 1344, 9376, 9408,
9440, 1344, 9472, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9696, 1344,
9728, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
| > > > > > > | > > > > > > > > > > > < < < < < < < < < < < < < < < < < | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > | | < < < < < | < < | < | | | | > | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > | | | > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > < < < | < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 9760, 9792, 9824, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9920, 1344, 1344, 9952, 1824, 9984, 10016,
10048, 1344, 1344, 10080, 10112, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 10144, 10176, 1344, 10208, 1344, 10240, 10272,
10304, 10336, 10368, 10400, 1344, 1344, 1344, 10432, 10464, 64, 10496,
10528, 10560, 4736, 10592, 10624
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10656, 10688, 10720, 1824, 1344, 1344, 1344, 10752, 10784, 10816,
10848, 10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 8480,
1344, 11040, 11072, 1344, 11104, 11136, 11168, 11200, 1344, 11232,
1824, 11264, 11296, 11328, 1344, 11360, 11392, 11424, 11456, 1344,
11488, 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7808, 4704, 10240, 1824, 1824, 1824,
1824, 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744,
11776, 1824, 1824, 1344, 11808, 11840, 6912, 11872, 11904, 11936, 11968,
12000, 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224,
1824, 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344,
12416, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448,
1344, 12480, 1824, 1824, 12000, 12512, 12544, 1824, 1824, 10176, 12576,
7808, 12608, 12640, 12672, 12704, 5280, 12736, 12768, 12800, 12832,
12864, 12896, 12928, 5280, 12960, 12992, 13024, 13056, 13088, 1824,
1824, 13120, 13152, 13184, 13216, 13248, 13280, 13312, 13344, 1824,
1824, 1824, 1824, 1344, 13376, 13408, 13440, 1344, 13472, 13504, 1824,
1824, 1824, 1824, 1824, 1344, 13536, 13568, 1824, 1344, 13600, 13632,
13664, 1344, 13696, 13728, 1824, 4032, 13760, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 13792, 1824, 1824, 1824, 13824, 13856, 13888, 13920,
13952, 13984, 1824, 1824, 14016, 14048, 14080, 14112, 14144, 14176,
1344, 14208, 14240, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 14272, 14304, 14336, 14368, 14400, 14432, 1824, 1824, 14464,
14496, 14528, 14560, 14592, 13728, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 14624, 1824, 1824, 1824, 1824, 1824, 14656, 14688,
14720, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 9952, 1824, 1824, 1824, 10848,
10848, 10848, 14752, 1344, 1344, 1344, 1344, 1344, 1344, 14784, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14816, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14848,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736,
14880, 1824, 1824, 10176, 14912, 1344, 14944, 14976, 15008, 15040,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13824, 13856,
15072, 1824, 1824, 1824, 1344, 1344, 15104, 15136, 15168, 1824, 1824,
15200, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 15232, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 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, 1824, 12256, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4736, 1824, 15264,
15296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 9824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 1344, 1344, 15328, 15360, 15392, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 8032, 4928, 15424, 4928, 15456, 15488, 15520, 4928, 15552,
4928, 4928, 15584, 1824, 1824, 1824, 1824, 15616, 4928, 4928, 15648,
15680, 1824, 1824, 1824, 1824, 15712, 15744, 15776, 15808, 15840, 15872,
15904, 15936, 15968, 16000, 16032, 16064, 16096, 15712, 15744, 16128,
15808, 16160, 16192, 16224, 15936, 16256, 16288, 16320, 16352, 16384,
16416, 16448, 16480, 16512, 16544, 16576, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704,
16608, 704, 16640, 16672, 16704, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
16736, 16768, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 16800, 16832,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344,
16864, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344,
16896, 1824, 16928, 16960, 16992, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 17024, 6912, 17056, 1824, 1824,
17088, 17120, 1824, 1824, 1824, 1824, 1824, 1824, 17152, 17184, 17216,
17248, 17280, 17312, 1824, 17344, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 4928, 17376, 4928, 4928, 8000, 17408, 17440, 8032, 17472,
4928, 4928, 4928, 4928, 17504, 1824, 17536, 17568, 17600, 17632, 17664,
1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17696,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17728,
17760, 4928, 4928, 4928, 8000, 4928, 4928, 17792, 17824, 17376, 4928,
17856, 4928, 17888, 17920, 1824, 1824, 4928, 4928, 4928, 17952, 4928,
4928, 17984, 4928, 4928, 4928, 8000, 18016, 18048, 18080, 18112, 1824,
4928, 4928, 4928, 4928, 18144, 4928, 6880, 18176, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 18208, 1344, 1344, 1344,
1344, 1344, 1344, 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 18240, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
18272, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 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
#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.
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
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, 93, 93, 93, 0, 0, 3, 0, 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, 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, 0, 15, 15, 15, 15, 15,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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, 93, 93, 93, 0, 0, 3, 0, 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, 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, 0, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 17, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 93, 125, 93, 15, 125, 125, 125, 93, 93, 93, 93,
93, 93, 93, 93, 125, 125, 125, 125, 93, 125, 125, 15, 93, 93, 93, 93,
93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 3, 3, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 93, 125, 125, 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, 93, 15, 125, 125, 125,
93, 93, 93, 93, 0, 0, 125, 125, 0, 0, 125, 125, 93, 15, 0, 0, 0, 0,
0, 0, 0, 0, 125, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 93, 93, 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, 93, 0, 0, 93, 93, 125, 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, 93, 0, 125, 125, 125, 93, 93,
0, 0, 0, 0, 93, 93, 0, 0, 93, 93, 93, 0, 0, 0, 93, 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, 93, 93, 15, 15, 15, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
93, 125, 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, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 0, 93,
93, 125, 0, 125, 125, 93, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3,
4, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 0, 93, 125, 125,
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, 93, 15, 125, 93, 125, 93, 93, 93, 93, 0, 0, 125, 125, 0,
0, 125, 125, 93, 0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 0, 0, 0, 0, 15,
15, 0, 15, 15, 15, 93, 93, 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, 93, 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,
125, 125, 93, 125, 125, 0, 0, 0, 125, 125, 125, 0, 125, 125, 125, 93,
0, 0, 15, 0, 0, 0, 0, 0, 0, 125, 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, 93, 125, 125, 125, 93, 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, 0, 15, 93,
93, 93, 125, 125, 125, 125, 0, 93, 93, 93, 0, 93, 93, 93, 93, 0, 0,
0, 0, 0, 0, 0, 93, 93, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 93, 93,
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, 93, 125, 125, 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, 93, 15, 125, 93,
125, 125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0,
0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 93, 93,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 93, 93, 125, 125, 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, 93, 93, 15, 125, 125,
125, 93, 93, 93, 93, 0, 125, 125, 125, 0, 125, 125, 125, 93, 15, 14,
0, 0, 0, 0, 15, 15, 15, 125, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15,
93, 93, 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, 93, 125, 125, 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, 93, 0, 0, 0,
0, 125, 125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125, 125,
125, 125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 125,
125, 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, 93, 15, 15, 93, 93, 93, 93, 93, 93,
93, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93, 93,
93, 93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 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, 93, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 93, 15, 0, 0, 15, 15, 15, 15, 15, 0, 92, 0,
93, 93, 93, 93, 93, 93, 0, 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, 93, 93, 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, 93, 14,
93, 14, 93, 5, 6, 5, 6, 125, 125, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 125, 93, 93, 93, 93, 93, 3, 93, 93, 15, 15, 15, 15, 15, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 14, 14, 14,
14, 14, 14, 14, 14, 93, 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, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93,
93, 93, 125, 93, 93, 125, 125, 93, 93, 15, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 15,
15, 15, 15, 93, 93, 93, 15, 125, 125, 125, 15, 15, 125, 125, 125, 125,
125, 125, 125, 15, 15, 15, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 125, 125, 93, 93, 125, 125, 125, 125,
125, 125, 93, 15, 125, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 125, 125, 125,
93, 14, 14, 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, 0,
126, 0, 0, 0, 0, 0, 126, 0, 0, 127, 127, 127, 127, 127, 127, 127, 127,
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 93, 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, 125, 93, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93,
125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 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, 92, 3, 3, 3, 3, 3, 3, 0, 0,
| | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | < | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | < | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | > | | | | | | | | | < | > | | | | | | | > > | < < | | | | | | | | | | | | | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | > | | | | > > | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | > | | | | | | | | | | | | | | | | | | > | > | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < > | | < < | | | | | | | | | | > > > > | | | | | | | | | | | | > > > < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | > | | | | | < | > > | | > > | > | 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 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 93, 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, 125, 93, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93,
125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 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, 92, 3, 3, 3, 3, 3, 3, 0, 0,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 93, 93,
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, 93, 93, 93, 93, 125, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 93, 93, 93, 125, 93, 125,
125, 125, 125, 125, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15, 0, 0,
0, 0, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 93, 93, 125, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 93, 93, 125, 125,
93, 93, 125, 93, 93, 93, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 125, 125,
125, 93, 125, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3,
3, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 93, 93,
93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 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, 92, 92,
92, 92, 92, 92, 3, 3, 130, 131, 132, 133, 133, 134, 135, 136, 137,
0, 0, 0, 0, 0, 0, 0, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 0, 0, 138, 138, 138, 3, 3, 3, 3, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 3, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15,
15, 93, 15, 15, 15, 15, 15, 15, 93, 15, 15, 125, 93, 93, 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, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 92, 139, 21, 21, 21, 140, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 141, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 0, 93, 93, 93, 93, 93, 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,
142, 21, 21, 143, 21, 144, 144, 144, 144, 144, 144, 144, 144, 145,
145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144, 144, 144, 0,
0, 145, 145, 145, 145, 145, 145, 0, 0, 144, 144, 144, 144, 144, 144,
144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144,
144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144,
144, 144, 144, 144, 0, 0, 145, 145, 145, 145, 145, 145, 0, 0, 21, 144,
21, 144, 21, 144, 21, 144, 0, 145, 0, 145, 0, 145, 0, 145, 144, 144,
144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145,
146, 146, 147, 147, 147, 147, 148, 148, 149, 149, 150, 150, 151, 151,
0, 0, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152, 152, 152,
152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152,
152, 152, 152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152,
152, 152, 152, 152, 152, 152, 152, 144, 144, 21, 153, 21, 0, 21, 21,
145, 145, 154, 154, 155, 11, 156, 11, 11, 11, 21, 153, 21, 0, 21, 21,
157, 157, 157, 157, 155, 11, 11, 11, 144, 144, 21, 21, 0, 0, 21, 21,
145, 145, 158, 158, 0, 11, 11, 11, 144, 144, 21, 21, 21, 114, 21, 21,
145, 145, 159, 159, 118, 11, 11, 11, 0, 0, 21, 153, 21, 0, 21, 21,
160, 160, 161, 161, 155, 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, 162, 163, 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, 92, 0, 0, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 92, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 120, 120, 120, 93, 120, 120,
120, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 108, 14, 14, 14, 14, 108, 14,
14, 21, 108, 108, 108, 21, 21, 108, 108, 108, 21, 14, 108, 14, 14,
7, 108, 108, 108, 108, 108, 14, 14, 14, 14, 14, 14, 108, 14, 164, 14,
108, 14, 165, 166, 108, 108, 14, 21, 108, 108, 167, 108, 21, 15, 15,
15, 15, 21, 14, 14, 21, 21, 108, 108, 7, 7, 7, 7, 7, 108, 21, 21, 21,
21, 14, 7, 14, 14, 168, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 169, 169, 169, 169, 169, 169, 169, 169, 169,
169, 169, 169, 169, 169, 169, 169, 170, 170, 170, 170, 170, 170, 170,
170, 170, 170, 170, 170, 170, 170, 170, 170, 129, 129, 129, 23, 24,
129, 129, 129, 129, 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, 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,
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,
171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 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,
172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 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, 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, 5, 6, 5, 6,
5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 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, 7, 7, 7,
7, 7, 5, 6, 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, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5,
6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 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, 5, 6, 5, 6, 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, 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, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 0, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 0, 23, 24, 173, 174, 175,
176, 177, 23, 24, 23, 24, 23, 24, 178, 179, 180, 181, 21, 23, 24, 21,
23, 24, 21, 21, 21, 21, 21, 92, 92, 182, 182, 23, 24, 23, 24, 21, 14,
14, 14, 14, 14, 14, 23, 24, 23, 24, 93, 93, 93, 23, 24, 0, 0, 0, 0,
0, 3, 3, 3, 3, 18, 3, 3, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 0, 183, 0, 0, 0, 0, 0, 183, 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, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 93, 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, 92,
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, 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, 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, 0, 0, 0, 0,
2, 3, 3, 3, 14, 92, 15, 129, 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, 129, 129, 129, 129, 129, 129,
129, 129, 129, 93, 93, 93, 93, 125, 125, 8, 92, 92, 92, 92, 92, 14,
14, 129, 129, 129, 92, 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, 93,
93, 11, 11, 92, 92, 15, 15, 15, 15, 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,
92, 92, 92, 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, 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, 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, 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, 92, 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, 92, 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, 93, 120, 120, 120, 3, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 3, 92, 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, 92, 92, 93, 93, 15, 15, 15, 15, 15, 15, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 93, 93, 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, 92, 92, 92, 92, 92, 92, 92, 92,
92, 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, 92, 21,
21, 21, 21, 21, 21, 21, 21, 23, 24, 23, 24, 184, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 92, 11, 11, 23, 24, 185, 21, 15, 23, 24, 23, 24,
186, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 187, 188, 189, 190, 187, 21, 191, 192, 193, 194,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 23, 24, 195,
196, 197, 23, 24, 23, 24, 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, 23, 24, 15, 92, 92, 21, 15, 15, 15, 15, 15, 15, 15,
93, 15, 15, 15, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125,
125, 93, 93, 125, 14, 14, 14, 14, 93, 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, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 93, 93, 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, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15,
15, 15, 3, 3, 3, 15, 3, 15, 15, 93, 15, 15, 15, 15, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 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, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 125, 125, 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, 93, 125, 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 125,
125, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 92, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 93, 92, 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, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 93, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 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, 92, 15, 15, 15, 15, 15, 15, 14,
14, 14, 15, 125, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 15, 93, 93, 93, 15, 15, 93, 93, 15,
15, 15, 15, 15, 93, 93, 15, 93, 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, 92, 3, 3, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 125, 125, 3, 3, 15, 92,
92, 125, 93, 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, 198, 21, 21, 21, 21, 21, 21, 21, 11, 92, 92, 92, 92,
21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 11, 11, 0, 0, 0, 0, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 15, 15, 15, 125, 125, 93, 125, 125, 93, 125, 125,
3, 125, 93, 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, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 200, 200, 200, 200, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 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,
93, 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, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 6, 5, 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, 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, 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, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 5,
6, 3, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 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,
92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 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, 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, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 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, 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, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93, 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, 93, 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, 129, 15, 15, 15, 15, 15, 15, 15, 15, 129, 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, 93, 93, 93, 93, 93, 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, 129, 129, 129, 129,
129, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 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, 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, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 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, 93, 93, 93, 0, 93, 93, 0, 0, 0, 0, 0, 93,
93, 93, 93, 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, 93, 93, 93, 0, 0, 0, 0, 93, 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, 93, 93, 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, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 0, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 93, 93, 93, 93,
0, 0, 0, 0, 0, 0, 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, 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, 93, 93, 8, 0, 0, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 18, 18, 18, 18, 3, 3, 3, 3, 3, 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, 125, 93, 125, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 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, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93,
93, 125, 125, 93, 93, 3, 3, 17, 3, 3, 3, 3, 0, 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, 93, 93, 93, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 93, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 125, 125, 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, 93, 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, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 15, 15, 15,
15, 3, 3, 3, 3, 93, 93, 93, 93, 3, 125, 93, 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, 125, 125, 125, 93, 93,
93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 93, 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, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93,
93, 125, 125, 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, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125, 0,
0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 125, 125, 0, 0, 93, 93, 93, 93,
93, 93, 93, 0, 0, 0, 93, 93, 93, 93, 93, 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, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 93, 125, 93, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 3, 93, 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,
125, 125, 125, 93, 93, 93, 93, 93, 93, 125, 93, 125, 125, 125, 125,
93, 93, 125, 93, 93, 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, 125, 125, 125, 93, 93, 93, 93, 0, 0,
125, 125, 125, 125, 93, 93, 125, 93, 93, 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, 93, 93, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 93, 125, 93,
93, 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, 93, 125, 93, 125, 125, 93, 93, 93,
93, 93, 93, 125, 93, 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, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 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, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93,
93, 93, 93, 93, 125, 93, 93, 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, 125, 125, 125, 125, 125,
125, 0, 125, 125, 0, 0, 93, 93, 125, 93, 15, 125, 15, 125, 93, 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,
125, 125, 125, 93, 93, 93, 93, 0, 0, 93, 93, 125, 125, 125, 125, 93,
15, 3, 15, 125, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 125, 15, 93, 93,
93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93,
93, 93, 93, 93, 93, 125, 125, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 125, 93, 93, 3, 3, 3, 15, 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, 0, 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, 125, 93, 93, 93,
93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 125, 93, 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, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 0, 125, 93, 93, 93, 93, 93, 93, 93, 125,
93, 93, 125, 93, 93, 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, 93, 93, 93, 93, 93, 93, 0, 0, 0,
93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 15, 93, 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, 125, 125, 125, 125, 125, 0, 93, 93, 0, 125, 125, 93,
125, 93, 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, 15, 93, 93, 125, 125, 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, 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, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 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, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 0, 0, 0,
0, 0, 0, 0, 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, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0,
93, 93, 93, 93, 93, 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, 93, 93, 93, 93, 93,
93, 93, 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, 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, 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, 93, 15, 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, 125, 125, 125, 125,
125, 125, 125, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 92, 93, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 125, 125, 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, 15, 15, 15, 0, 0, 0, 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, 93, 93, 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, 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, 125, 125, 93, 93, 93, 14, 14, 14, 125, 125, 125, 125, 125, 125,
17, 17, 17, 17, 17, 17, 17, 17, 93, 93, 93, 93, 93, 93, 93, 93, 14,
14, 93, 93, 93, 93, 93, 93, 93, 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, 93, 93, 93, 93, 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, 14, 14, 93, 93, 93, 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, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 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, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 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, 108,
0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108, 108, 108, 108, 0,
108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 0, 108, 108, 108, 108, 0,
0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108,
108, 108, 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, 108, 108, 0, 108, 108,
108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0, 0, 0, 108, 108, 108,
108, 108, 108, 108, 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, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 108, 108, 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, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 0, 0, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 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, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 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, 108, 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, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14,
14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93,
14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93,
93, 0, 93, 93, 93, 93, 93, 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, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 92, 92, 92, 92, 92, 92, 92,
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, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 4, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 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, 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, 205, 205, 93, 93, 93, 93, 93,
93, 93, 92, 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, 0, 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, 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, 0, 0, 0, 0, 0, 0, 0, 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, 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, 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, 0, 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, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14,
14, 14, 14, 0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 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,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 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, 0, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
#endif /* TCL_UTF_MAX > 3 */
};
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
| | | | 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x31360)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
|
| ︙ | ︙ | |||
1659 1660 1661 1662 1663 1664 1665 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ | | | | | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ #define GetCaseType(info) (((info) & 0xE0) >> 5) #define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #else # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #endif |
Changes to generic/tclUtf.c.
1 2 3 4 5 | /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. * * Copyright © 1997-1998 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" |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | * Unicode characters less than this value are represented by themselves in * UTF-8 strings. */ #define UNICODE_SELF 0x80 /* | | > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > | 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 |
* Unicode characters less than this value are represented by themselves in
* UTF-8 strings.
*/
#define UNICODE_SELF 0x80
/*
* The following structures are used when mapping between Unicode and
* UTF-8.
*/
static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,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,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
1,1,1,1,1,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
static const unsigned char complete[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,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,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
3,3,3,3,3,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
/*
* Functions used only in this module.
*/
static int Invalid(const char *src);
/*
*---------------------------------------------------------------------------
*
* TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
/*
*---------------------------------------------------------------------------
*
* Invalid --
*
* Given a pointer to a two-byte prefix of a well-formed UTF-8 byte
* sequence (a lead byte followed by a trail byte) this routine
* examines those two bytes to determine whether the sequence is
* invalid in UTF-8. This might be because it is an overlong
* encoding, or because it encodes something out of the proper range.
*
* Given a pointer to the bytes \xF8 or \xFC , this routine will
* try to read beyond the end of the "bounds" table. Callers must
* prevent this.
*
* Given a pointer to something else (an ASCII byte, a trail byte,
* or another byte that can never begin a valid byte sequence such
* as \xF5) this routine returns false. That makes the routine poorly
* named, as it does not detect and report all invalid sequences.
*
* Callers have to take care that this routine does something useful
* for their needs.
*
* Results:
* A boolean.
*---------------------------------------------------------------------------
*/
static const unsigned char bounds[28] = {
0x80, 0x80, /* \xC0 accepts \x80 only */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF,
0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */
0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
};
static int
Invalid(
const char *src) /* Points to lead byte of a UTF-8 byte sequence */
{
unsigned char byte = UCHAR(*src);
int index;
if ((byte & 0xC3) == 0xC0) {
/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
index = (byte - 0xC0) >> 1;
if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) {
/* Out of bounds - report invalid. */
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharToUtf --
*
* Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static const unsigned short cp1252[32] = {
| | | | 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 |
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static const unsigned short cp1252[32] = {
0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
#undef Tcl_UtfToUniChar
int
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.
*/
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
| | | | | > | < | 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 |
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
* the UTF-8 string. This could be a surrogate too. */
{
unsigned short byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
* do that if the high surrogate matches the bits we encounter.
*/
if (((byte & 0xC0) == 0x80)
&& ((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)
&& (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC))
&& ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))) {
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
if ((unsigned)(byte-0x80) < (unsigned)0x20) {
*chPtr = cp1252[byte-0x80];
} else {
*chPtr = byte;
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | | | > | | < < > | | 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 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high < 0x400) {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
/* out of range, < 0x10000 or > 0x10FFFF */
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 |
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
int ch = 0, *w, *wString;
| | > > > > | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
int ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length < 0) {
length = strlen(src);
}
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 |
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(int)));
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
| | > | | < < | | < | | > | | < | > > > > | 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 |
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(int)));
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
*w++ = UCHAR(*p++);
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
unsigned short *
Tcl_UtfToChar16DString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
unsigned short ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length < 0) {
length = strlen(src);
}
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(unsigned short)));
wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
| | > | < | | > | < > | 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 |
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(unsigned short)));
wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 3;
while (p <= optPtr) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
if (TclChar16Complete(p, endPtr-p)) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
}
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfCharComplete --
*
* Determine if the UTF-8 string of the given length is long enough to be
* decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 |
int
Tcl_UtfCharComplete(
const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
int length) /* Length of above string in bytes. */
{
| | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
int
Tcl_UtfCharComplete(
const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
int length) /* Length of above string in bytes. */
{
return length >= complete[UCHAR(*src)];
}
/*
*---------------------------------------------------------------------------
*
* Tcl_NumUtfChars --
*
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
*
*---------------------------------------------------------------------------
*/
int
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
| | | < < < < < < < > | < > > > | > > > > > > > > > | > > | | | > > > > > | | < < > | < < < | < < < < < | < | | < < | < | < < < < < | < | | | | > > > | | > > > | > > | > > > | > > > > > | | | > > > > > > > > > | > > | 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 |
*
*---------------------------------------------------------------------------
*/
int
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
int length) /* The length of the string in bytes, or -1
* for strlen(string). */
{
Tcl_UniChar ch = 0;
int i = 0;
if (length < 0) {
/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
while ((*src != '\0') && (i < INT_MAX)) {
src += TclUtfToUniChar(src, &ch);
i++;
}
} else {
/* Will return value between 0 and length. No overflow checks. */
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
/*
* Optimize away the call in this loop. Justified because...
* when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr)
* By initialization above (endPtr - optPtr) = TCL_UTF_MAX
* So (endPtr - src) >= TCL_UTF_MAX, and passing that to
* Tcl_UtfCharComplete we know will cause return of 1.
*/
while (src <= optPtr
/* && Tcl_UtfCharComplete(src, endPtr - src) */ ) {
src += TclUtfToUniChar(src, &ch);
i++;
}
/* Loop over the remaining string where call must happen */
while (src < endPtr) {
if (Tcl_UtfCharComplete(src, endPtr - src)) {
src += TclUtfToUniChar(src, &ch);
} else {
/*
* src points to incomplete UTF-8 sequence
* Treat first byte as character and count it
*/
src++;
}
i++;
}
}
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindFirst --
*
* Returns a pointer to the first occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string,
* the return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
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 = TclUtfToUCS4(src, &find);
if (find == ch) {
return src;
}
if (*src == '\0') {
return NULL;
}
src += len;
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindLast --
*
* Returns a pointer to the last occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string, the
* return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
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 = TclUtfToUCS4(src, &find);
if (find == ch) {
last = src;
}
if (*src == '\0') {
break;
}
src += len;
}
return last;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfNext --
*
* Given a pointer to some location in a UTF-8 string, Tcl_UtfNext
* returns a pointer to the next UTF-8 character in the string.
* The caller must not ask for the next character after the last
* character in the string if the string is not terminated by a null
* character.
*
* Results:
* The return value is the pointer to the next character in the UTF-8
* string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
int left;
const char *next;
if (((*src) & 0xC0) == 0x80) {
if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) {
++src;
}
return src;
}
left = totalBytes[UCHAR(*src)];
next = src + 1;
while (--left) {
if ((*next & 0xC0) != 0x80) {
/*
* src points to non-trail byte; We ran out of trail bytes
* before the needs of the lead byte were satisfied.
* Let the (malformed) lead byte alone be a character
*/
return src + 1;
}
next++;
}
/*
* Call Invalid() here only if required conditions are met:
* src[0] is known a lead byte.
* src[1] is known a trail byte.
* Especially important to prevent calls when src[0] == '\xF8' or '\xFC'
* See tests utf-6.37 through utf-6.43 through valgrind or similar tool.
*/
if ((next == src + 1) || Invalid(src)) {
return src + 1;
}
return next;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfPrev --
*
|
| ︙ | ︙ | |||
905 906 907 908 909 910 911 | * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfPrev( | | | < > | | > > > > < < > | < | | < | > | > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > | | | | | | | < | < | < < | | < < > > | | 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 |
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfPrev(
const char *src, /* A location in a UTF-8 string. */
const char *start) /* Pointer to the beginning of the string */
{
int trailBytesSeen = 0; /* How many trail bytes have been verified? */
const char *fallback = src - 1;
/* If we cannot find a lead byte that might
* start a prefix of a valid UTF byte sequence,
* we will fallback to a one-byte back step */
const char *look = fallback;
/* Start search at the fallback position */
/* Quick boundary case exit. */
if (fallback <= start) {
return start;
}
do {
unsigned char byte = UCHAR(look[0]);
if (byte < 0x80) {
/*
* Single byte character. Either this is a correct previous
* character, or it is followed by at least one trail byte
* which indicates a malformed sequence. In either case the
* correct result is to return the fallback.
*/
return fallback;
}
if (byte >= 0xC0) {
/* Non-trail byte; May be multibyte lead. */
if ((trailBytesSeen == 0)
/*
* We've seen no trailing context to use to check
* anything. From what we know, this non-trail byte
* is a prefix of a previous character, and accepting
* it (the fallback) is correct.
*/
|| (trailBytesSeen >= complete[byte])) {
/*
* That is, (1 + trailBytesSeen > needed).
* We've examined more bytes than needed to complete
* this lead byte. No matter about well-formedness or
* validity, the sequence starting with this lead byte
* will never include the fallback location, so we must
* return the fallback location. See test utf-7.17
*/
return fallback;
}
/*
* trailBytesSeen > 0, so we can examine look[1] safely.
* Use that capability to screen out invalid sequences.
*/
if (Invalid(look)) {
/* Reject */
return fallback;
}
return (const char *)look;
}
/* We saw a trail byte. */
trailBytesSeen++;
if ((const char *)look == start) {
/*
* Do not read before the start of the string
*
* If we get here, we've examined bytes at every location
* >= start and < src and all of them are trail bytes,
* including (*start). We need to return our fallback
* and exit this loop before we run past the start of the string.
*/
return fallback;
}
/* Continue the search backwards... */
look--;
} while (trailBytesSeen < TCL_UTF_MAX);
/*
* We've seen TCL_UTF_MAX trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
* accepting the fallback (for TCL_UTF_MAX > 3) or just go back as
* far as we can.
*/
#if TCL_UTF_MAX > 3
return fallback;
#else
return src - TCL_UTF_MAX;
#endif
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharAtIndex --
*
* Returns the Unicode character represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
int index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int i = 0;
if (index < 0) {
return -1;
}
while (index-- > 0) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (i < 3)) {
/* Index points at character following high Surrogate */
return -1;
}
#endif
TclUtfToUCS4(src, &i);
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
int ch, upChar;
char *src, *dst;
int len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(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.
*/
if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
int ch, lowChar;
char *src, *dst;
int len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(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.
*/
if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
| < | | < < < < < < < < | | | < < < < < < < | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
int ch, titleChar, lowChar;
char *src, *dst;
int len;
/*
* Capitalize the first character and then lowercase the rest of the
* characters until we get to a null.
*/
src = dst = str;
if (*src) {
len = TclUtfToUCS4(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUCS4(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)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
| > | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
|
| ︙ | ︙ | |||
1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
| > | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
|
| ︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
| > | 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 1823 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
| > | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
/* Clear away extension bits, if any */
ch &= 0x1FFFFF;
if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007F))) {
return 1;
}
if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) {
return 1;
}
return 0;
}
|
| ︙ | ︙ | |||
1875 1876 1877 1878 1879 1880 1881 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1928 1929 1930 1931 1932 1933 1934 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
| | | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
return TclIsSpaceProcM((char) ch);
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 |
return 0;
}
string++;
pattern++;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
return 0;
}
string++;
pattern++;
}
}
/*
*---------------------------------------------------------------------------
*
* TclUtfToUCS4 --
*
* Extract the 4-byte codepoint from the leading bytes of the
* Modified UTF-8 string "src". This is a utility routine to
* contain the surrogate gymnastics in one place.
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
* *usc4Ptr is filled with the UCS4 code point, and the return value is
* the number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#if TCL_UTF_MAX <= 3
int
TclUtfToUCS4(
const char *src, /* The UTF-8 string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the UTF-8 string. */
{
/* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
return Tcl_UtfToUniChar(src, ucs4Ptr);
}
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
*ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[1] & 0x3FF)) + 0x10000;
return 2;
}
*ucs4Ptr = src[0];
return 1;
}
const Tcl_UniChar *TclUCS4Prev(const Tcl_UniChar *src, const Tcl_UniChar *ptr) {
if (src <= ptr + 1) {
return ptr;
}
if (((src[-1] & 0xFC00) == 0xDC00) && ((src[-2] & 0xFC00) == 0xD800)) {
return src - 2;
}
return src - 1;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclUtil.c.
1 2 3 4 5 6 | /* * tclUtil.c -- * * This file contains utility functions that are used by many Tcl * commands. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclUtil.c -- * * This file contains utility functions that are used by many Tcl * commands. * * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2001 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 "tclParse.h" |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 | /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, |
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
goto done;
}
/*
* No list element before leading white space.
*/
| | | | | | 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 |
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProcM(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == -1) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != -1);
} while (numBytes && TclIsSpaceProcM(*bytes));
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != -1);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProcM(bytes[-1]);
done:
if (endPtr) {
*endPtr = bytes;
}
return count;
}
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
| | | | 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 |
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0;
int numChars;
int literal = 1;
const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
*/
limit = (string + stringLength);
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
if (p == limit) { /* no element found */
elemStart = limit;
goto done;
}
|
| ︙ | ︙ | |||
634 635 636 637 638 639 640 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
| | | | 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 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (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",
|
| ︙ | ︙ | |||
678 679 680 681 682 683 684 | literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; | < < < < < < < < < < < < < < < < < | | > > > > > > > > > > > > > > | 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 |
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (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",
NULL);
}
return TCL_ERROR;
}
break;
default:
if (TclIsSpaceProcM(*p)) {
/*
* Space: ignore if element is in braces or quotes;
* otherwise terminate element.
*/
if ((openBraces == 0) && !inQuotes) {
size = (p - elemStart);
goto done;
}
}
break;
}
p++;
}
/*
* End of list/dict: terminate element.
*/
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
| | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
*elementPtr = elemStart;
*nextPtr = p;
if (sizePtr != 0) {
*sizePtr = size;
}
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
| | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
const char *prevList = list;
int literal;
result = TclFindElement(interp, list, length, &element, &list,
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 | break; #else /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ | < < < < < < | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 | break; #else /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ forbidNone = 1; extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\\': /* TYPE_SUBS */ |
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 |
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
}
}
length -= (length > 0);
p++;
}
| > > > > > > > > > | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 |
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
default:
if (TclIsSpaceProcM(*p)) {
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif
}
break;
}
}
length -= (length > 0);
p++;
}
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 |
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
| | | | | 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 |
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
result = (char *)ckalloc(1);
result[0] = '\0';
return result;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)ckalloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - argc + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += argc;
/*
* Pass two: copy into the result area.
*/
result = (char *)ckalloc(bytesNeeded);
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 |
return (char) ch;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > > | | | > > > > | | > > | > | < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > > > | > > > > | | | 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 |
return (char) ch;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the right side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimRight(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
const char *q = trim;
int pInc = 0, bytesLeft = numTrim;
pp = TclUtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
} while (pp + pInc < p);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is last non-trimmed char.
*/
break;
}
p = pp;
} while (p > bytes);
return numBytes - (p - bytes);
}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the left side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
int pInc = TclUtfToUCS4(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
/*
*----------------------------------------------------------------------
*
* TclTrim --
* Finds the sub string (offset) to trim from both sides of the
* first string all characters found in the second string.
|
| ︙ | ︙ | |||
1911 1912 1913 1914 1915 1916 1917 1918 1919 |
*----------------------------------------------------------------------
*/
int
TclTrim(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
int numTrim, /* ...and its length in bytes */
| > > > > | | < < | < | | < < | | > > | > | > | | < < | | < | | | | | < < | | 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 |
*----------------------------------------------------------------------
*/
int
TclTrim(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
int *trimRightPtr) /* Offset from the end of the string. */
{
int trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
/* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */
trimLeft = TclTrimLeft(bytes, numBytes, trim, numTrim);
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 += TclUtfToUCS4(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
/* When bytes is NUL-terminated, returns
* 0 <= trimRight <= numBytes */
trimRight = TclTrimRight(bytes, numBytes, trim, numTrim);
}
}
}
*trimRightPtr = trimRight;
return trimLeft;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Concat --
|
| ︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 |
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
| | | 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 |
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
result = (char *)ckalloc(bytesNeeded + argc);
for (p = result, i = 0; i < argc; i++) {
int triml, trimr, elemLength;
const char *element;
element = argv[i];
elemLength = strlen(argv[i]);
|
| ︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 |
goto slow;
}
} else {
resPtr = TclListObjCopy(NULL, objPtr);
}
}
if (!resPtr) {
| | | 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
goto slow;
}
} else {
resPtr = TclListObjCopy(NULL, objPtr);
}
}
if (!resPtr) {
TclNewObj(resPtr);
}
return resPtr;
}
slow:
/*
* Something cannot be determined to be safe, so build the concatenation
|
| ︙ | ︙ | |||
2238 2239 2240 2241 2242 2243 2244 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
| < | | 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
int ch1 = 0, ch2 = 0;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If so,
* we succeeded. If we're at the end of the pattern but not at the end
|
| ︙ | ︙ | |||
2280 2281 2282 2283 2284 2285 2286 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
| | | | | | | | | | | | | | > | > > | | 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 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUCS4(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 = TclUtfToUCS4(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 = TclUtfToUCS4(str, &ch1);
if (ch2 == ch1) {
break;
}
str += charLen;
}
}
}
if (Tcl_StringCaseMatch(str, pattern, nocase)) {
return 1;
}
if (*str == '\0') {
return 0;
}
str += TclUtfToUCS4(str, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
str += TclUtfToUCS4(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 += TclUtfToUCS4(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 += TclUtfToUCS4(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 += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
/* If we reach here, we matched. Need to move past closing ] */
while (*pattern != ']') {
if (*pattern == '\0') {
/* We ran out of pattern after matching something in
* (unclosed!) brackets. So long as we ran out of string
* at the same time, we have a match. Otherwise, not. */
return (*str == '\0');
}
pattern++;
}
pattern++;
continue;
}
|
| ︙ | ︙ | |||
2431 2432 2433 2434 2435 2436 2437 | } /* * There's no special character. Just make sure that the next bytes of * each string match. */ | | | | 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 |
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
TclByteArrayMatch(
const unsigned char *string,/* String. */
int strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
| | | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 |
TclByteArrayMatch(
const unsigned char *string,/* String. */
int strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2747 2748 2749 2750 2751 2752 2753 |
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
| | | | 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 |
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
offset = bytes - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
bytes = dsPtr->string + offset;
}
}
}
|
| ︙ | ︙ | |||
2835 2836 2837 2838 2839 2840 2841 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
| | > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | < > | < < < < < < < | 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 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = 0;
int quoteHash = 1, newSize;
if (needSpace) {
/*
* If we need a space to separate the new element from something
* already ending the string, we're not appending the first element
* of any list, so we need not quote any leading hash character.
*/
quoteHash = 0;
} else {
/*
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
if (!quoteHash) {
flags |= TCL_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
* may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
offset = element - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
}
dst = dsPtr->string + dsPtr->length;
/*
* Convert the new string to a list element and copy it into the buffer at
* the end, with a space, if needed.
*/
if (needSpace) {
*dst = ' ';
dst++;
dsPtr->length++;
}
dsPtr->length += TclConvertElement(element, -1, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2944 2945 2946 2947 2948 2949 2950 |
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
| | | | 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 |
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
dsPtr->length = length;
dsPtr->string[length] = 0;
}
/*
|
| ︙ | ︙ | |||
3041 3042 3043 3044 3045 3046 3047 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
| | | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
Tcl_Obj *obj = Tcl_GetObjResult(interp);
const char *bytes = TclGetString(obj);
Tcl_DStringFree(dsPtr);
Tcl_DStringAppend(dsPtr, bytes, obj->length);
Tcl_ResetResult(interp);
#else
|
| ︙ | ︙ | |||
3101 3102 3103 3104 3105 3106 3107 |
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
| | | | 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 |
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
iPtr->freeProc(iPtr->result);
}
dsPtr->spaceAvl = dsPtr->length+1;
iPtr->freeProc = NULL;
} else {
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
dsPtr->spaceAvl = dsPtr->length + 1;
}
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
|
| ︙ | ︙ | |||
3259 3260 3261 3262 3263 3264 3265 | * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble( | | < < | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_PrintDouble(
TCL_UNUSED(Tcl_Interp *),
double value, /* Value to print as string. */
char *dst) /* Where to store converted value; must have
* at least TCL_DOUBLE_SPACE characters. */
{
char *p, c;
int exponent;
int signum;
char *digits;
char *end;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* Handle NaN.
*/
if (TclIsNaN(value)) {
TclFormatNaN(value, dst);
|
| ︙ | ︙ | |||
3434 3435 3436 3437 3438 3439 3440 | * effect of the variable modification. Otherwise it modifies the format * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 | < | | | 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 |
* effect of the variable modification. Otherwise it modifies the format
* string that's used by Tcl_PrintDouble.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *
TclPrecTraceProc(
ClientData clientData,
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
Tcl_Obj *value;
Tcl_WideInt prec;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
|
| ︙ | ︙ | |||
3519 3520 3521 3522 3523 3524 3525 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
| < > > > > > > < | > > > > > > > > > > > | | | | > > > > > > > > > | | < < < < < < < < > > | < < < < < > | > | | < < < < < < < < | < | 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 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
*
* (NOTE: This check is now absorbed into the loop below.)
*
if (end == start) {
return 0;
}
*
*/
/*
* (b) we're at the start of a nested list-element, quoted with an open
* curly brace; we can be nested arbitrarily deep, so long as the
* first curly brace starts an element, so backtrack over open curly
* braces that are trailing characters of the string; and
*
* (NOTE: Every character our parser is looking for is a proper
* single-byte encoding of an ASCII value. It does not accept
* overlong encodings. Given that, there's no benefit using
* Tcl_UtfPrev. If it would find what we seek, so would byte-by-byte
* backward scan. Save routine call overhead and risk of wrong
* results should the behavior of Tcl_UtfPrev change in unexpected ways.
* 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.
*/
if (TclIsSpaceProcM(*end)) {
int result = 0;
/*
* Trailing whitespace might be part of a backslash escape
* sequence. Handle that possibility.
*/
while ((--end >= start) && (*end == '\\')) {
result = !result;
}
return result;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3682 3683 3684 3685 3686 3687 3688 3689 |
Tcl_Obj *objPtr, /* Points to the value to be parsed */
size_t 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. */
{
ClientData cd;
| > < < | < < < < | | | | | | < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
Tcl_Obj *objPtr, /* Points to the value to be parsed */
size_t 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;
ClientData cd;
int code = TclGetNumberFromObj(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;
return TCL_OK;
}
if (numType == TCL_NUMBER_BIG) {
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
*widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX);
return TCL_OK;
}
}
/* objPtr does not hold a number, check the end+/- format... */
return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntForIndex --
*
|
| ︙ | ︙ | |||
3875 3876 3877 3878 3879 3880 3881 |
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
| | | > | | | | > > | | > | | > > > > > > > > > > > > | > > > > > | > | > | > > > > > > | > > > > > | > > > > > | > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | > > > > > > > > > > > > | | | | | | | > > > > > > > > > > > > > > > > | 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 |
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
* representing an index. May be NULL.*/
{
Tcl_WideInt wide;
if (GetWideForIndex(interp, objPtr, (size_t)(endValue + 1) - 1, &wide) == TCL_ERROR) {
return TCL_ERROR;
}
if (indexPtr != NULL) {
if ((wide < 0) && (endValue > TCL_INDEX_END)) {
*indexPtr = -1;
} else if (wide > INT_MAX) {
*indexPtr = INT_MAX;
} else if (wide < INT_MIN) {
*indexPtr = INT_MIN;
} else {
*indexPtr = (int) wide;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
* Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
* convert it to an internal representation.
*
* The internal representation (wideValue) uses the following encoding:
*
* WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
* WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
* -$n: Index "end-[expr {$n-1}]"
* -2: Index "end-1"
* -1: Index "end"
* 0: Index "0"
* WIDE_MAX-1: Index "end+n", for any n > 1
* WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static int
GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjIntRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
ClientData cd;
while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjIntRep ir;
int 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" */
/* If we reach here, the string rep of objPtr exists. */
/*
* The valid index syntax does not include any value that is
* a list of more than one element. This is necessary so that
* lists of index values can be reliably distinguished from any
* single index value.
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(bytes, -1, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == Tcl_ListObjLength(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, -1, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
/* Save first integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
if (t1 == TCL_NUMBER_INT) {
w1 = (*(Tcl_WideInt *)cd);
}
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
-1, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* ... value concludes with second valid integer */
/* Save second integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
if (t2 == TCL_NUMBER_INT) {
w2 = (*(Tcl_WideInt *)cd);
}
}
}
/* Clear invalid intreps left by TclParseNumber */
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
if (w2 == WIDE_MIN) {
goto extreme;
}
w2 = -w2;
}
if ((w1 ^ w2) < 0) {
/* Different signs, sum cannot overflow */
offset = w1 + w2;
} else if (w1 >= 0) {
if (w1 < WIDE_MAX - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MAX;
}
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
} else {
/*
* At least one is big, do bignum math. Little reason to
* value performance here. Re-use code. Parse has verified
* objPtr is an expression. Compute it.
*/
Tcl_Obj *sum;
extreme:
if (interp) {
Tcl_ExprObj(interp, objPtr, &sum);
} else {
Tcl_Interp *compute = Tcl_CreateInterp();
Tcl_ExprObj(compute, objPtr, &sum);
Tcl_DeleteInterp(compute);
}
TclGetNumberFromObj(NULL, sum, &cd, &numType);
if (numType == TCL_NUMBER_INT) {
/* sum holds an integer in the signed wide range */
offset = *(Tcl_WideInt *)cd;
} else {
/* sum holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = WIDE_MIN;
} else {
offset = WIDE_MAX;
}
}
Tcl_DecrRefCount(sum);
}
if (offset < 0) {
offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1;
}
goto parseOK;
}
}
goto parseError;
}
if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
/* Doesn't start with "end" */
goto parseError;
}
if (length > 4) {
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
goto parseError;
}
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. */
TclGetNumberFromObj(NULL, objPtr, &cd, &t);
if (t == TCL_NUMBER_BIG) {
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
} else {
offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
}
} else {
/* assert (t == TCL_NUMBER_INT); */
offset = (*(Tcl_WideInt *)cd);
if (bytes[3] == '-') {
offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
}
if (offset == 1) {
offset = WIDE_MAX; /* "end+1" */
} else if (offset > 1) {
offset = WIDE_MAX - 1; /* "end+n", out of range */
} else if (offset != WIDE_MIN) {
offset--;
}
}
}
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
*widePtr = endValue + 1;
} else if (offset == WIDE_MIN) {
*widePtr = -1;
} else if (endValue == (size_t)-1) {
*widePtr = offset;
} else if (offset < 0) {
/* Different signs, sum cannot overflow */
*widePtr = endValue + offset + 1;
} else if (offset < WIDE_MAX) {
*widePtr = offset;
} else {
*widePtr = WIDE_MAX;
}
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;
}
TclCheckBadOctal(interp, bytes);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
*
|
| ︙ | ︙ | |||
4028 4029 4030 4031 4032 4033 4034 | * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The | | | | | | 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 | * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The * index "end" is encoded as -2, down to the index "end-0x7FFFFFFE" * which is encoded as INT_MIN. Since the largest index into a * string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of * "end-0x7FFFFFFE" for that largest string would be 0. Thus, * if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed, * they can be encoded with the before value. * * These details will require re-examination whenever string and * list length limits are increased, but that will likely also * mean a revised routine capable of returning Tcl_WideInt values. * * Returns: |
| ︙ | ︙ | |||
4057 4058 4059 4060 4061 4062 4063 |
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
int before, /* Value to return for index before beginning */
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
| < | < < < < | < < > | < > | < < < < | | | | | | | | | | | | | | | | | < < < < < < < < < < | 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 |
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
int before, /* Value to return for index before beginning */
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &endOffsetType);
if (irPtr && irPtr->wideValue >= 0) {
/* "int[+-]int" syntax, works the same here as "int" */
irPtr = NULL;
}
/*
* We parsed an end+offset index value.
* wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
*/
if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
/*
* All end+postive or end-negative expressions
* always indicate "after the end".
*/
idx = after;
} else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) {
/* These indices always indicate "before the beginning */
idx = before;
} else {
/* Encoded end-positive (or end+negative) are offset */
idx = (int)wide;
}
} else {
return TCL_ERROR;
}
*indexPtr = idx;
return TCL_OK;
}
|
| ︙ | ︙ | |||
4171 4172 4173 4174 4175 4176 4177 |
const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted leading
* zero. Try to generate a meaningful error message.
*/
| | | | 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 |
const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted leading
* zero. Try to generate a meaningful error message.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '+' || *p == '-') {
p++;
}
if (*p == '0') {
if ((p[1] == 'o') || p[1] == 'O') {
p += 2;
}
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
}
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '\0') {
/*
* Reached end of string.
*/
|
| ︙ | ︙ | |||
4226 4227 4228 4229 4230 4231 4232 |
Tcl_HashTable *tablePtr)
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 |
Tcl_HashTable *tablePtr)
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(objPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
|
| ︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 |
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
| | | | 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 |
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
(Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
|
| ︙ | ︙ | |||
4284 4285 4286 4287 4288 4289 4290 |
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
ClientData clientData)
{
| | | 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 |
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
ClientData clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
}
/*
|
| ︙ | ︙ | |||
4306 4307 4308 4309 4310 4311 4312 |
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(
ClientData clientData)
{
| | | 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 |
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(
ClientData clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
ckfree(pgvPtr->value);
pgvPtr->value = NULL;
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
|
| ︙ | ︙ | |||
4355 4356 4357 4358 4359 4360 4361 |
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = TclGetString(newValue);
pgvPtr->numBytes = newValue->length;
| | | 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 |
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = TclGetString(newValue);
pgvPtr->numBytes = newValue->length;
pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
pgvPtr->encoding = encoding;
/*
|
| ︙ | ︙ | |||
4404 4405 4406 4407 4408 4409 4410 |
unsigned int epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
| | | | | 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 |
unsigned int 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.
*/
Tcl_DString native, newValue;
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, &native);
Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
Tcl_DStringLength(&native), &newValue);
Tcl_DStringFree(&native);
ckfree(pgvPtr->value);
pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
|
| ︙ | ︙ | |||
4469 4470 4471 4472 4473 4474 4475 |
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
| | | 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 |
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
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 --
*
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
1 2 3 4 5 6 7 8 9 | /* * tclVar.c -- * * This file contains routines that implement Tcl variables (both scalars * and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclVar.c -- * * This file contains routines that implement Tcl variables (both scalars * and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * * Copyright © 1987-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2007 Miguel Sofer * * 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 "tclOOInt.h" |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
Tcl_DeleteHashTable(&(tablePtr)->table)
/*
* The strings below are used to indicate what went wrong when a variable
* access is denied.
*/
| | | | | | | | | | | 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 |
Tcl_DeleteHashTable(&(tablePtr)->table)
/*
* The strings below are used to indicate what went wrong when a variable
* access is denied.
*/
static const char NOSUCHVAR[] = "no such variable";
static const char ISARRAY[] = "variable is array";
static const char NEEDARRAY[] = "variable isn't array";
static const char NOSUCHELEMENT[] = "no such element in array";
static const char DANGLINGELEMENT[] =
"upvar refers to element in deleted array";
static const char DANGLINGVAR[] =
"upvar refers to variable in deleted namespace";
static const char BADNAMESPACE[] = "parent namespace doesn't exist";
static const char MISSINGNAME[] = "missing variable name";
static const char ISARRAYELEMENT[] =
"name refers to an element in an array";
/*
* A test to see if we are in a call frame that has local variables. This is
* true if we are inside a procedure body.
*/
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 | Tcl_Obj *patternPtr, int includeLinks); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_NRPostProc ArrayForLoopCallback; | | < | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | Tcl_Obj *patternPtr, int includeLinks); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_NRPostProc ArrayForLoopCallback; static Tcl_ObjCmdProc ArrayForNRCmd; static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, |
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
} while (0)
#define LocalGetIntRep(objPtr, index, name) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &localVarNameType); \
| | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
} while (0)
#define LocalGetIntRep(objPtr, index, name) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL
};
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
} while (0)
#define ParsedGetIntRep(objPtr, parsed, array, elem) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \
(parsed) = (irPtr != NULL); \
| | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
} while (0)
#define ParsedGetIntRep(objPtr, parsed, array, elem) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((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)
|
| ︙ | ︙ | |||
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,
| | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
/*
* 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", NULL);
}
return NULL;
}
part2Ptr = elem;
part1Ptr = arrayPtr;
goto restart;
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
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,
| | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
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",
NULL);
}
return NULL;
}
arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr,
(Tcl_Namespace *) cxtNsPtr,
(flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
if (!create) { /* Var wasn't found and not to create it. */
| | | | | 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 |
varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr,
(Tcl_Namespace *) cxtNsPtr,
(flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
if (!create) { /* Var wasn't found and not to create it. */
*errMsgPtr = NOSUCHVAR;
return NULL;
}
/*
* Var wasn't found so create it.
*/
TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags,
&varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
if (varNsPtr == NULL) {
*errMsgPtr = BADNAMESPACE;
return NULL;
} else if (tail == NULL) {
*errMsgPtr = MISSINGNAME;
return NULL;
}
if (tail != varName) {
tailPtr = Tcl_NewStringObj(tail, -1);
} else {
tailPtr = varNamePtr;
}
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
}
}
}
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
| | | | 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 |
}
}
}
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
if (tablePtr != NULL) {
varPtr = VarHashFindVar(tablePtr, varNamePtr);
}
if (varPtr == NULL) {
*errMsgPtr = NOSUCHVAR;
}
}
}
return varPtr;
}
/*
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 |
* 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,
| | | | | 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 |
* 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, 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, 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, NULL);
}
return NULL;
}
|
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 |
TclSetVarArrayElement(varPtr);
}
} else {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elNamePtr);
if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
| | | 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 |
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), NULL);
}
}
}
return varPtr;
}
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
return avhtPtr->defaultObj;
}
}
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
| | | | | 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 |
return avhtPtr->defaultObj;
}
}
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
msg = NOSUCHELEMENT;
} else if (TclIsVarArray(varPtr)) {
msg = ISARRAY;
} else {
msg = NOSUCHVAR;
}
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index);
}
/*
* 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.
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
|
| ︙ | ︙ | |||
2022 2023 2024 2025 2026 2027 2028 |
* allocation and is meaningless anyway).
*/
if (TclIsVarDeadHash(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarArrayElement(varPtr)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
| | | | | 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 |
* allocation and is meaningless anyway).
*/
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", NULL);
} else {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", 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", NULL);
}
goto earlyError;
}
/*
* Invoke any read traces that have been set for the variable if it is
|
| ︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
| | | 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 |
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
TclNewIntObj(varValuePtr, 0);
}
if (Tcl_IsShared(varValuePtr)) {
/* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 |
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
| | | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", 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
|
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 | * Transfer any existing traces on var, IF there are unset traces. * Otherwise just delete them. */ int isNew; tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); | | | 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 |
* Transfer any existing traces on var, IF there are unset traces.
* Otherwise just delete them.
*/
int isNew;
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
Tcl_DeleteHashEntry(tPtr);
if (dummyVar.flags & VAR_TRACED_UNSET) {
tPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
&dummyVar, &isNew);
Tcl_SetHashValue(tPtr, tracePtr);
}
|
| ︙ | ︙ | |||
2730 2731 2732 2733 2734 2735 2736 |
* the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
if (tPtr) {
| | | 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 |
* the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
if (tPtr) {
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
Tcl_DeleteHashEntry(tPtr);
}
}
}
if (tracePtr) {
ActiveVarTrace *activePtr;
|
| ︙ | ︙ | |||
2816 2817 2818 2819 2820 2821 2822 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, flags = TCL_LEAVE_ERR_MSG;
const char *name;
|
| ︙ | ︙ | |||
2884 2885 2886 2887 2888 2889 2890 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler warning. */
|
| ︙ | ︙ | |||
2950 2951 2952 2953 2954 2955 2956 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_LappendObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
int numElems, createdNewObj;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
3159 3160 3161 3162 3163 3164 3165 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
| | | | | 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 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, ArrayForNRCmd, clientData, objc, objv);
}
static int
ArrayForNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
ArraySearch *searchPtr = NULL;
Var *varPtr;
|
| ︙ | ︙ | |||
3217 3218 3219 3220 3221 3222 3223 |
return NotArrayError(interp, arrayNameObj);
}
/*
* Make a new array search, put it on the stack.
*/
| | | 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
return NotArrayError(interp, arrayNameObj);
}
/*
* Make a new array search, put it on the stack.
*/
searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
|
| ︙ | ︙ | |||
3245 3246 3247 3248 3249 3250 3251 |
static int
ArrayForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 |
static int
ArrayForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ArraySearch *searchPtr = (ArraySearch *)data[0];
Tcl_Obj *varListObj = (Tcl_Obj *)data[1];
Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj **varv;
Tcl_Obj *keyObj, *valueObj;
Var *varPtr;
Var *arrayPtr;
int done, varc;
/*
|
| ︙ | ︙ | |||
3368 3369 3370 3371 3372 3373 3374 |
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
searchPtr->id = 1;
varPtr->flags |= VAR_SEARCH_ACTIVE;
searchPtr->nextPtr = NULL;
} else {
searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
| | | 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 |
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
searchPtr->id = 1;
varPtr->flags |= VAR_SEARCH_ACTIVE;
searchPtr->nextPtr = NULL;
} else {
searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
searchPtr->nextPtr = (ArraySearch *)Tcl_GetHashValue(hPtr);
}
searchPtr->varPtr = varPtr;
searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
Tcl_SetHashValue(hPtr, searchPtr);
searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
TclGetString(arrayNameObj));
|
| ︙ | ︙ | |||
3396 3397 3398 3399 3400 3401 3402 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayStartSearchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
int isArray;
ArraySearch *searchPtr;
|
| ︙ | ︙ | |||
3426 3427 3428 3429 3430 3431 3432 |
return NotArrayError(interp, objv[1]);
}
/*
* Make a new array search with a free name.
*/
| | | 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 |
return NotArrayError(interp, objv[1]);
}
/*
* Make a new array search with a free name.
*/
searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr);
Tcl_SetObjResult(interp, searchPtr->name);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3467 3468 3469 3470 3471 3472 3473 |
if (searchPtr->nextPtr) {
Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
} else {
varPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(hPtr);
}
} else {
| | | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 |
if (searchPtr->nextPtr) {
Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
} else {
varPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(hPtr);
}
} else {
for (prevPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); ; prevPtr=prevPtr->nextPtr) {
if (prevPtr->nextPtr == searchPtr) {
prevPtr->nextPtr = searchPtr->nextPtr;
break;
}
}
}
}
|
| ︙ | ︙ | |||
3493 3494 3495 3496 3497 3498 3499 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayAnyMoreCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
|
| ︙ | ︙ | |||
3572 3573 3574 3575 3576 3577 3578 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayNextElementCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
|
| ︙ | ︙ | |||
3653 3654 3655 3656 3657 3658 3659 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayDoneSearchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
|
| ︙ | ︙ | |||
3714 3715 3716 3717 3718 3719 3720 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *)interp;
int isArray;
|
| ︙ | ︙ | |||
3755 3756 3757 3758 3759 3760 3761 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayGetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2;
Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
Tcl_Obj **nameObjPtr, *patternObj;
|
| ︙ | ︙ | |||
3915 3916 3917 3918 3919 3920 3921 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayNamesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-exact", "-glob", "-regexp", NULL
};
enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
Var *varPtr, *varPtr2;
Tcl_Obj *nameObj, *resultObj, *patternObj;
Tcl_HashSearch search;
const char *pattern = NULL;
int isArray, mode = OPT_GLOB;
if ((objc < 2) || (objc > 4)) {
|
| ︙ | ︙ | |||
3994 3995 3996 3997 3998 3999 4000 |
continue;
}
nameObj = VarHashGetKey(varPtr2);
if (patternObj) {
const char *name = TclGetString(nameObj);
int matched = 0;
| | | 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 |
continue;
}
nameObj = VarHashGetKey(varPtr2);
if (patternObj) {
const char *name = TclGetString(nameObj);
int matched = 0;
switch ((enum arrayNamesOptionsEnum) mode) {
case OPT_EXACT:
Tcl_Panic("exact matching shouldn't get here");
case OPT_GLOB:
matched = Tcl_StringMatch(name, pattern);
break;
case OPT_REGEXP:
matched = Tcl_RegExpMatchObj(interp, nameObj, patternObj);
|
| ︙ | ︙ | |||
4083 4084 4085 4086 4087 4088 4089 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArraySetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *arrayNameObj;
Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
4114 4115 4116 4117 4118 4119 4120 |
/*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
if (arrayPtr) {
CleanupVar(varPtr, arrayPtr);
| | | 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 |
/*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
/*createPart2*/ 1, &arrayPtr);
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), NULL);
return TCL_ERROR;
}
/*
* Install the contents of the dictionary or list into the array.
|
| ︙ | ︙ | |||
4233 4234 4235 4236 4237 4238 4239 |
}
if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
* Either an array element, or a scalar: lose!
*/
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
| | | 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 |
}
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", NULL);
return TCL_ERROR;
}
}
TclInitArrayVar(varPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4259 4260 4261 4262 4263 4264 4265 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArraySizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_HashSearch search;
Var *varPtr2;
|
| ︙ | ︙ | |||
4297 4298 4299 4300 4301 4302 4303 |
varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (!TclIsVarUndefined(varPtr2)) {
size++;
}
}
}
| | | 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 |
varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
if (!TclIsVarUndefined(varPtr2)) {
size++;
}
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArrayStatsCmd --
|
| ︙ | ︙ | |||
4319 4320 4321 4322 4323 4324 4325 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayStatsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_Obj *varNameObj;
char *stats;
|
| ︙ | ︙ | |||
4374 4375 4376 4377 4378 4379 4380 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayUnsetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
4511 4512 4513 4514 4515 4516 4517 | * * Side effects: * Creates a command in the global namespace. * *---------------------------------------------------------------------- */ | < | 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 |
*
* Side effects:
* Creates a command in the global namespace.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
|
| ︙ | ︙ | |||
5003 5004 5005 5006 5007 5008 5009 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_GlobalObjCmd( | | | 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr, *tailPtr;
const char *varName;
|
| ︙ | ︙ | |||
5107 5108 5109 5110 5111 5112 5113 | * result in the interpreter's result object. * *---------------------------------------------------------------------- */ int Tcl_VariableObjCmd( | | | 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 |
* result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
Tcl_VariableObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
5138 5139 5140 5141 5142 5143 5144 |
if (arrayPtr != NULL) {
/*
* 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",
| | | 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 |
if (arrayPtr != NULL) {
/*
* 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", NULL);
return TCL_ERROR;
}
if (varPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
5238 5239 5240 5241 5242 5243 5244 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpvarObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
int result, hasLevel;
Tcl_Obj *levelObj;
|
| ︙ | ︙ | |||
5355 5356 5357 5358 5359 5360 5361 |
char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
/* First look for same (Tcl_Obj *) */
| | | | 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 |
char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
/* First look for same (Tcl_Obj *) */
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->name == handleObj) {
return searchPtr;
}
}
/* Fallback: do string compares. */
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
return searchPtr;
}
}
}
if ((handle[0] != 's') || (handle[1] != '-')
|
| ︙ | ︙ | |||
5414 5415 5416 5417 5418 5419 5420 |
* deleted. */
{
ArraySearch *searchPtr, *nextPtr;
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
| | | 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 |
* deleted. */
{
ArraySearch *searchPtr, *nextPtr;
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(sPtr);
|
| ︙ | ︙ | |||
5466 5467 5468 5469 5470 5471 5472 |
flags = TCL_GLOBAL_ONLY;
} else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) {
flags = TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
| | > | | 5447 5448 5449 5450 5451 5452 5453 5454 5455 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 |
flags = TCL_GLOBAL_ONLY;
} else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) {
flags = TCL_NAMESPACE_ONLY;
}
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr;
TclNewObj(objPtr);
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
NULL, flags, -1);
/*
* We just unset the variable. However, an unset trace might
* have re-set it, or might have re-established traces on it.
* This namespace and its vartable are going away unconditionally,
* so we cannot let such things linger. That would be a leak.
*
* First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
ActiveVarTrace *activePtr;
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
5681 5682 5683 5684 5685 5686 5687 | Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); elPtr->flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, elNamePtr, flags,/* leaveErrMsg */ 0, index); } tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr); | | | 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 |
Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);
elPtr->flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
elNamePtr, flags,/* leaveErrMsg */ 0, index);
}
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
|
| ︙ | ︙ | |||
6052 6053 6054 6055 6056 6057 6058 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoVarsCmd( | | | 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoVarsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6135 6136 6137 6138 6139 6140 6141 |
*/
varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr);
if (varPtr) {
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
if (specificNsInPattern) {
| | | 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 |
*/
varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr);
if (varPtr) {
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = VarHashGetKey(varPtr);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
|
| ︙ | ︙ | |||
6168 6169 6170 6171 6172 6173 6174 |
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
varNamePtr = VarHashGetKey(varPtr);
varName = TclGetString(varNamePtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
| | | 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 |
if (!TclIsVarUndefined(varPtr)
|| TclIsVarNamespaceVar(varPtr)) {
varNamePtr = VarHashGetKey(varPtr);
varName = TclGetString(varNamePtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = varNamePtr;
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
|
| ︙ | ︙ | |||
6243 6244 6245 6246 6247 6248 6249 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoGlobalsCmd( | | | 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoGlobalsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6336 6337 6338 6339 6340 6341 6342 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoLocalsCmd( | | | 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoLocalsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *patternPtr, *listPtr;
|
| ︙ | ︙ | |||
6487 6488 6489 6490 6491 6492 6493 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
Method *mPtr = (Method *)
| | | 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
Method *mPtr = (Method *)
Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData);
PrivateVariableMapping *privatePtr;
if (mPtr->declaringObjectPtr) {
Object *oPtr = mPtr->declaringObjectPtr;
FOREACH(objNamePtr, oPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
|
| ︙ | ︙ | |||
6551 6552 6553 6554 6555 6556 6557 |
Tcl_InitCustomHashTable(&tablePtr->table,
TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
tablePtr->nsPtr = nsPtr;
}
static Tcl_HashEntry *
AllocVarEntry(
| | | | | 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 |
Tcl_InitCustomHashTable(&tablePtr->table,
TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
tablePtr->nsPtr = nsPtr;
}
static Tcl_HashEntry *
AllocVarEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr;
Var *varPtr;
varPtr = (Var *)ckalloc(sizeof(VarInHash));
varPtr->flags = VAR_IN_HASHTABLE;
varPtr->value.objPtr = NULL;
VarHashRefCount(varPtr) = 1;
hPtr = &(((VarInHash *) varPtr)->entry);
Tcl_SetHashValue(hPtr, varPtr);
hPtr->key.objPtr = objPtr;
|
| ︙ | ︙ | |||
6594 6595 6596 6597 6598 6599 6600 |
}
static int
CompareVarKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
| | | 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 |
}
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;
int l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
|
| ︙ | ︙ | |||
6639 6640 6641 6642 6643 6644 6645 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayDefaultCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"get", "set", "exists", "unset", NULL
};
enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET };
Tcl_Obj *arrayNameObj, *defaultValueObj;
Var *varPtr, *arrayPtr;
int isArray, option;
/*
* Parse arguments.
*/
|
| ︙ | ︙ | |||
6674 6675 6676 6677 6678 6679 6680 |
arrayNameObj = objv[2];
if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
}
| | | 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 |
arrayNameObj = objv[2];
if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
}
switch ((enum arrayDefaultOptionsEnum)option) {
case OPT_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
return TCL_ERROR;
}
if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) {
return NotArrayError(interp, arrayNameObj);
|
| ︙ | ︙ | |||
6717 6718 6719 6720 6721 6722 6723 |
if (arrayPtr) {
/*
* Not a valid array name.
*/
CleanupVar(varPtr, arrayPtr);
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
| | | | 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 |
if (arrayPtr) {
/*
* 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), 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", NULL);
return TCL_ERROR;
}
if (!TclIsVarArray(varPtr)) {
TclInitArrayVar(varPtr);
}
|
| ︙ | ︙ | |||
6788 6789 6790 6791 6792 6793 6794 |
* Initialize array variable.
*/
void
TclInitArrayVar(
Var *arrayPtr)
{
| | | 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 |
* Initialize array variable.
*/
void
TclInitArrayVar(
Var *arrayPtr)
{
ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable));
/*
* Mark the variable as an array.
*/
TclSetVarArray(arrayPtr);
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
1 2 3 4 5 6 | /* * tclZipfs.c -- * * Implementation of the ZIP filesystem used in TIP 430 * Adapted from the implentation for AndroWish. * | | | > > > > > > > | 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 | /* * tclZipfs.c -- * * Implementation of the ZIP filesystem used in TIP 430 * Adapted from the implentation for AndroWish. * * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com> * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This file is distributed in two ways: * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 * projects. */ #include "tclInt.h" #include "tclFileSystem.h" #ifndef _WIN32 #include <sys/mman.h> #endif /* _WIN32*/ #ifndef MAP_FILE #define MAP_FILE 0 #endif /* !MAP_FILE */ #define NOBYFOUR #define crc32tab crc_table[0] #ifndef TBLS #define TBLS 1 #endif #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" #include "zutil.h" #include "crc32.h" #ifdef CFG_RUNTIME_DLLFILE /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix */ |
| ︙ | ︙ | |||
285 286 287 288 289 290 291 |
* For password rotation.
*/
static const char pwrot[17] =
"\x00\x80\x40\xC0\x20\xA0\x60\xE0"
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
* For password rotation.
*/
static const char pwrot[17] =
"\x00\x80\x40\xC0\x20\xA0\x60\xE0"
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
static const char *zipfs_literal_tcl_library = NULL;
/* Function prototypes */
static inline int DescribeMounted(Tcl_Interp *interp,
const char *mountPoint);
static inline int ListMountPoints(Tcl_Interp *interp);
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, | | | < > > | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, Tcl_Interp *interp, int flags); static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); #ifndef TCL_NO_DEPRECATED static int ZipChannelSeek(void *instanceData, long offset, int mode, int *errloc); #endif static Tcl_WideInt ZipChannelWideSeek(void *instanceData, Tcl_WideInt offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, int mask); static int ZipChannelWrite(void *instanceData, const char *buf, int toWrite, int *errloc); |
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
/*
* The channel type/driver definition used for ZIP archive members.
*/
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
| | > > > > | | 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 |
/*
* The channel type/driver definition used for ZIP archive members.
*/
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
TCL_CLOSE2PROC, /* Close channel, clean instance data */
ZipChannelRead, /* Handle read request */
ZipChannelWrite, /* Handle write request */
#ifndef TCL_NO_DEPRECATED
ZipChannelSeek, /* Move location of access point, NULL'able */
#else
NULL, /* Move location of access point, NULL'able */
#endif
NULL, /* Set options, NULL'able */
NULL, /* Get options, NULL'able */
ZipChannelWatchChannel, /* Initialize notifier */
ZipChannelGetFile, /* Get OS handle from the channel */
ZipChannelClose, /* 2nd version of close channel, NULL'able */
NULL, /* Set blocking mode for raw channel, NULL'able */
NULL, /* Function to flush channel, NULL'able */
NULL, /* Function to handle event, NULL'able */
ZipChannelWideSeek, /* Wide seek function, NULL'able */
NULL, /* Thread action function, NULL'able */
NULL, /* Truncate function, NULL'able */
};
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
char *filename)
{
Tcl_HashEntry *hPtr;
ZipEntry *z = NULL;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
if (hPtr) {
| | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 |
char *filename)
{
Tcl_HashEntry *hPtr;
ZipEntry *z = NULL;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
if (hPtr) {
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
}
return z;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
931 932 933 934 935 936 937 |
}
if (zf->mountHandle != INVALID_HANDLE_VALUE) {
CloseHandle(zf->mountHandle);
}
#else /* !_WIN32 */
if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
munmap(zf->data, zf->length);
| | | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 |
}
if (zf->mountHandle != INVALID_HANDLE_VALUE) {
CloseHandle(zf->mountHandle);
}
#else /* !_WIN32 */
if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
munmap(zf->data, zf->length);
zf->data = (unsigned char *)MAP_FAILED;
}
#endif /* _WIN32 */
if (zf->ptrToFree) {
ckfree(zf->ptrToFree);
zf->ptrToFree = NULL;
}
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
zf->nameLength = 0;
zf->isMemBuffer = 0;
#ifdef _WIN32
zf->data = NULL;
zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
| | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
zf->nameLength = 0;
zf->isMemBuffer = 0;
#ifdef _WIN32
zf->data = NULL;
zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
zf->data = (unsigned char *)MAP_FAILED;
#endif /* _WIN32 */
zf->length = 0;
zf->numFiles = 0;
zf->baseOffset = zf->passOffset = 0;
zf->ptrToFree = NULL;
zf->passBuf[0] = 0;
zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 |
}
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
| | | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 |
}
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
zf->ptrToFree = zf->data = (unsigned char *)attemptckalloc(zf->length);
if (!zf->ptrToFree) {
ZIPFS_ERROR(interp, "out of memory");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
zf->length = GetFileSize((HANDLE) handle, 0);
readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
# endif /* _WIN64 */
if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
ZIPFS_POSIX_ERROR(interp, "invalid file size");
goto error;
}
| | | | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
zf->length = GetFileSize((HANDLE) handle, 0);
readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
# endif /* _WIN64 */
if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
ZIPFS_POSIX_ERROR(interp, "invalid file size");
goto error;
}
zf->mountHandle = CreateFileMappingW((HANDLE) handle, 0, PAGE_READONLY,
0, zf->length, 0);
if (zf->mountHandle == INVALID_HANDLE_VALUE) {
ZIPFS_POSIX_ERROR(interp, "file mapping failed");
goto error;
}
zf->data = (unsigned char *)MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0,
zf->length);
if (!zf->data) {
ZIPFS_POSIX_ERROR(interp, "file mapping failed");
goto error;
}
#else /* !_WIN32 */
zf->length = lseek(PTR2INT(handle), 0, SEEK_END);
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 |
mountPoint = "";
} else {
mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
}
hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
if (!isNew) {
if (interp) {
| | | | | | | | 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 |
mountPoint = "";
} else {
mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
}
hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
if (!isNew) {
if (interp) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s is already mounted on %s", zf->name, mountPoint));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
Unlock();
*zf = *zf0;
zf->mountPoint = (char *)Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
Tcl_CreateExitHandler(ZipfsExitHandler, zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = (char *)ckalloc(zf->nameLength + 1);
memcpy(zf->name, zipname, zf->nameLength + 1);
zf->entries = NULL;
zf->topEnts = NULL;
zf->numOpen = 0;
Tcl_SetHashValue(hPtr, zf);
if ((zf->passBuf[0] == 0) && pwlen) {
int k = 0;
zf->passBuf[k++] = pwlen;
for (i = pwlen; i-- > 0 ;) {
zf->passBuf[k++] = (passwd[i] & 0x0f)
| pwrot[(passwd[i] >> 4) & 0x0f];
}
zf->passBuf[k] = '\0';
}
if (mountPoint[0] != '\0') {
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
if (isNew) {
z = (ZipEntry *)ckalloc(sizeof(ZipEntry));
Tcl_SetHashValue(hPtr, z);
z->tnext = NULL;
z->depth = CountSlashes(mountPoint);
z->zipFilePtr = zf;
z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
z->isEncrypted = 0;
z->offset = zf->baseOffset;
z->crc32 = 0;
z->timestamp = 0;
z->numBytes = z->numCompressedBytes = 0;
z->compressMethod = ZIP_COMPMETH_STORED;
z->data = NULL;
z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
z->next = zf->entries;
zf->entries = z;
}
}
q = zf->data + zf->directoryOffset;
Tcl_DStringInit(&fpBuf);
for (i = 0; i < zf->numFiles; i++) {
|
| ︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 | * Regular files skipped when mounting on root. */ goto nextent; #endif /* ANDROID */ } Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); | | | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 | * Regular files skipped when mounting on root. */ goto nextent; #endif /* ANDROID */ } Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); z->name = NULL; z->tnext = NULL; z->depth = CountSlashes(fullpath); z->zipFilePtr = zf; z->isDirectory = isdir; z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) && (nbcompr > 12); |
| ︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 |
z->data = NULL;
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
if (!isNew) {
/* should not happen but skip it anyway */
ckfree(z);
} else {
Tcl_SetHashValue(hPtr, z);
| | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
z->data = NULL;
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
if (!isNew) {
/* should not happen but skip it anyway */
ckfree(z);
} else {
Tcl_SetHashValue(hPtr, z);
z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
z->next = zf->entries;
zf->entries = z;
if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) {
z->tnext = zf->topEnts;
zf->topEnts = z;
}
if (!z->isDirectory && (z->depth > 1)) {
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
for (end = strrchr(dir, '/'); end && (end != dir);
end = strrchr(dir, '/')) {
Tcl_DStringSetLength(&ds, end - dir);
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
if (!isNew) {
break;
}
| | | | 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 |
for (end = strrchr(dir, '/'); end && (end != dir);
end = strrchr(dir, '/')) {
Tcl_DStringSetLength(&ds, end - dir);
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
if (!isNew) {
break;
}
zd = (ZipEntry *)ckalloc(sizeof(ZipEntry));
zd->name = NULL;
zd->tnext = NULL;
zd->depth = CountSlashes(dir);
zd->zipFilePtr = zf;
zd->isDirectory = 1;
zd->isEncrypted = 0;
zd->offset = z->offset;
zd->crc32 = 0;
zd->timestamp = z->timestamp;
zd->numBytes = zd->numCompressedBytes = 0;
zd->compressMethod = ZIP_COMPMETH_STORED;
zd->data = NULL;
Tcl_SetHashValue(hPtr, zd);
zd->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
zd->next = zf->entries;
zf->entries = zd;
if ((mountPoint[0] == '\0') && (zd->depth == 1)) {
zd->tnext = zf->topEnts;
zf->topEnts = zd;
}
}
|
| ︙ | ︙ | |||
1555 1556 1557 1558 1559 1560 1561 |
ZipFile *zf;
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
if (!interp) {
return TCL_OK;
}
| | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
ZipFile *zf;
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
if (!interp) {
return TCL_OK;
}
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_AppendElement(interp, zf->mountPoint);
Tcl_AppendElement(interp, zf->name);
}
return (interp ? TCL_OK : TCL_BREAK);
}
/*
|
| ︙ | ︙ | |||
1592 1593 1594 1595 1596 1597 1598 |
{
Tcl_HashEntry *hPtr;
ZipFile *zf;
if (interp) {
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
if (hPtr) {
| | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
{
Tcl_HashEntry *hPtr;
ZipFile *zf;
if (interp) {
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
if (hPtr) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
return TCL_OK;
}
}
return (interp ? TCL_OK : TCL_BREAK);
}
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
}
| | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
}
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 |
}
Unlock();
/*
* Have both a mount point and data to mount there.
*/
| | | | 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 |
}
Unlock();
/*
* Have both a mount point and data to mount there.
*/
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
zf->isMemBuffer = 1;
zf->length = datalen;
if (copy) {
zf->data = (unsigned char *)attemptckalloc(datalen);
if (!zf->data) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 |
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
/* don't report no-such-mount as an error */
if (!hPtr) {
goto done;
}
| | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 |
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
/* don't report no-such-mount as an error */
if (!hPtr) {
goto done;
}
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->numOpen > 0) {
ZIPFS_ERROR(interp, "filesystem is busy");
ret = TCL_ERROR;
goto done;
}
Tcl_DeleteHashEntry(hPtr);
for (z = zf->entries; z; z = znext) {
|
| ︙ | ︙ | |||
1879 1880 1881 1882 1883 1884 1885 | * A ZIP archive file is mounted, resources are allocated. * *------------------------------------------------------------------------- */ static int ZipFSMountObjCmd( | | > | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?mountpoint? ?zipfile? ?password?");
return TCL_ERROR;
}
return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL,
|
| ︙ | ︙ | |||
1913 1914 1915 1916 1917 1918 1919 | * A ZIP archive file is mounted, resources are allocated. * *------------------------------------------------------------------------- */ static int ZipFSMountBufferObjCmd( | | | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountBufferObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
int length;
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 |
if (objc < 3) {
ReadLock();
DescribeMounted(interp, mountPoint);
Unlock();
return TCL_OK;
}
| | > > > | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 |
if (objc < 3) {
ReadLock();
DescribeMounted(interp, mountPoint);
Unlock();
return TCL_OK;
}
data = TclGetBytesFromObj(interp, objv[2], &length);
if (data == NULL) {
return TCL_ERROR;
}
return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSRootObjCmd --
|
| ︙ | ︙ | |||
1965 1966 1967 1968 1969 1970 1971 | * Side effects: * *------------------------------------------------------------------------- */ static int ZipFSRootObjCmd( | | | | | 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 |
* Side effects:
*
*-------------------------------------------------------------------------
*/
static int
ZipFSRootObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 | * A mounted ZIP archive file is unmounted, resources are free'd. * *------------------------------------------------------------------------- */ static int ZipFSUnmountObjCmd( | | > | 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
* A mounted ZIP archive file is unmounted, resources are free'd.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSUnmountObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
return TCL_ERROR;
}
return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
}
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 | * None. * *------------------------------------------------------------------------- */ static int ZipFSMkKeyObjCmd( | | | 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkKeyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int len, i = 0;
char *pw, passBuf[264];
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 | i); Tcl_AppendObjToErrorInfo(interp, eiPtr); Tcl_Close(interp, in); return TCL_ERROR; } ch = (int) (r * 256); | | < | | | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 |
i);
Tcl_AppendObjToErrorInfo(interp, eiPtr);
Tcl_Close(interp, in);
return TCL_ERROR;
}
ch = (int) (r * 256);
kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < 12 - 2; i++) {
kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], 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, 12);
memset(kvbuf, 0, 24);
if (len != 12) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 |
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"non-unique path name \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
return TCL_ERROR;
}
| | | | 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 |
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"non-unique path name \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
return TCL_ERROR;
}
z = (ZipEntry *)ckalloc(sizeof(ZipEntry));
Tcl_SetHashValue(hPtr, z);
z->name = NULL;
z->tnext = NULL;
z->depth = 0;
z->zipFilePtr = NULL;
z->isDirectory = 0;
z->isEncrypted = (passwd ? 1 : 0);
z->offset = pos[0];
z->crc32 = crc;
z->timestamp = mtime;
z->numBytes = nbyte;
z->numCompressedBytes = nbytecompr;
z->compressMethod = compMeth;
z->data = NULL;
z->name = (char *)Tcl_GetHashKey(fileHash, hPtr);
z->next = NULL;
/*
* Write final local header information.
*/
ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
|
| ︙ | ︙ | |||
2559 2560 2561 2562 2563 2564 2565 |
/*
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
/*
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (strcmp(zf->name, imgName) == 0) {
isMounted = 1;
zf->numOpen++;
break;
}
}
Unlock();
|
| ︙ | ︙ | |||
2720 2721 2722 2723 2724 2725 2726 |
if (name[0] == '\0') {
continue;
}
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
| | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
if (name[0] == '\0') {
continue;
}
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
len = strlen(z->name);
ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG);
ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod);
ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp));
|
| ︙ | ︙ | |||
2775 2776 2777 2778 2779 2780 2781 |
ret = Tcl_Close(interp, out);
} else {
Tcl_Close(interp, out);
}
Tcl_DecrRefCount(list);
for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 |
ret = Tcl_Close(interp, out);
} else {
Tcl_Close(interp, out);
}
Tcl_DecrRefCount(list);
for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
ckfree(z);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&fileHash);
return ret;
}
|
| ︙ | ︙ | |||
2802 2803 2804 2805 2806 2807 2808 | * See description of ZipFSMkZipOrImgCmd(). * *------------------------------------------------------------------------- */ static int ZipFSMkZipObjCmd( | | | | 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 |
* See description of ZipFSMkZipOrImgCmd().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkZipObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv);
}
static int
ZipFSLMkZipObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2859 2860 2861 2862 2863 2864 2865 | * See description of ZipFSMkZipOrImgCmd(). * *------------------------------------------------------------------------- */ static int ZipFSMkImgObjCmd( | | | | 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 |
* See description of ZipFSMkZipOrImgCmd().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkImgObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 6) {
Tcl_WrongNumArgs(interp, 1, objv,
"outfile indir ?strip? ?password? ?infile?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv);
}
static int
ZipFSLMkImgObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2917 2918 2919 2920 2921 2922 2923 | * None. * *------------------------------------------------------------------------- */ static int ZipFSCanonicalObjCmd( | | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSCanonicalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *mntpoint = NULL;
char *filename = NULL;
char *result;
|
| ︙ | ︙ | |||
2973 2974 2975 2976 2977 2978 2979 | * None. * *------------------------------------------------------------------------- */ static int ZipFSExistsObjCmd( | | | 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSExistsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
int exists;
Tcl_DString ds;
|
| ︙ | ︙ | |||
3026 3027 3028 3029 3030 3031 3032 | * None. * *------------------------------------------------------------------------- */ static int ZipFSInfoObjCmd( | | | 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSInfoObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
ZipEntry *z;
|
| ︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 | * None. * *------------------------------------------------------------------------- */ static int ZipFSListObjCmd( | | | 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *pattern = NULL;
Tcl_RegExp regexp = NULL;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
3115 3116 3117 3118 3119 3120 3121 |
} else if (objc == 2) {
pattern = Tcl_GetString(objv[1]);
}
ReadLock();
if (pattern) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | | 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 |
} else if (objc == 2) {
pattern = Tcl_GetString(objv[1]);
}
ReadLock();
if (pattern) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if (Tcl_StringMatch(z->name, pattern)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
} else if (regexp) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
} else {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
Unlock();
return TCL_OK;
|
| ︙ | ︙ | |||
3273 3274 3275 3276 3277 3278 3279 | * This cache is never cleared. * *------------------------------------------------------------------------- */ static int ZipFSTclLibraryObjCmd( | | | | | | 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 |
* This cache is never cleared.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSTclLibraryObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
if (!Tcl_IsSafe(interp)) {
Tcl_Obj *pResult = TclZipfs_TclLibrary();
if (!pResult) {
TclNewObj(pResult);
}
Tcl_SetObjResult(interp, pResult);
}
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3308 3309 3310 3311 3312 3313 3314 |
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelClose(
void *instanceData,
| | > | > > > > | | 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 |
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelClose(
void *instanceData,
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ZipChannel *info = (ZipChannel *)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (info->iscompr && info->ubuf) {
ckfree(info->ubuf);
info->ubuf = NULL;
}
if (info->isEncrypted) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
}
if (info->isWriting) {
ZipEntry *z = info->zipEntryPtr;
unsigned char *newdata = (unsigned char *)attemptckrealloc(info->ubuf, info->numRead);
if (newdata) {
if (z->data) {
ckfree(z->data);
}
z->data = newdata;
z->numBytes = z->numCompressedBytes = info->numBytes;
|
| ︙ | ︙ | |||
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 |
*errloc = EINVAL;
return -1;
}
info->numRead = (size_t) offset;
return info->numRead;
}
static int
ZipChannelSeek(
void *instanceData,
long offset,
int mode,
int *errloc)
{
return ZipChannelWideSeek(instanceData, offset, mode, errloc);
}
/*
*-------------------------------------------------------------------------
*
* ZipChannelWatchChannel --
*
* This function is called for event notifications on channel. Does
* nothing.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static void
ZipChannelWatchChannel(
| > > | | | 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 |
*errloc = EINVAL;
return -1;
}
info->numRead = (size_t) offset;
return info->numRead;
}
#ifndef TCL_NO_DEPRECATED
static int
ZipChannelSeek(
void *instanceData,
long offset,
int mode,
int *errloc)
{
return ZipChannelWideSeek(instanceData, offset, mode, errloc);
}
#endif
/*
*-------------------------------------------------------------------------
*
* ZipChannelWatchChannel --
*
* This function is called for event notifications on channel. Does
* nothing.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static void
ZipChannelWatchChannel(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*mask*/)
{
return;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3592 3593 3594 3595 3596 3597 3598 | * None. * *------------------------------------------------------------------------- */ static int ZipChannelGetFile( | | | | | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelGetFile(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*direction*/,
TCL_UNUSED(ClientData *) /*handlePtr*/)
{
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3621 3622 3623 3624 3625 3626 3627 |
*/
static Tcl_Channel
ZipChannelOpen(
Tcl_Interp *interp, /* Current interpreter. */
char *filename,
int mode,
| | | 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 |
*/
static Tcl_Channel
ZipChannelOpen(
Tcl_Interp *interp, /* Current interpreter. */
char *filename,
int mode,
TCL_UNUSED(int) /*permissions*/)
{
ZipEntry *z;
ZipChannel *info;
int i, ch, trunc, wr, flags = 0;
char cname[128];
if ((mode & O_APPEND)
|
| ︙ | ︙ | |||
3683 3684 3685 3686 3687 3688 3689 |
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
}
goto error;
}
} else {
flags = TCL_WRITABLE;
}
| | | | 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 |
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
}
goto error;
}
} else {
flags = TCL_WRITABLE;
}
info = (ZipChannel *)attemptckalloc(sizeof(ZipChannel));
if (!info) {
ZIPFS_ERROR(interp, "out of memory");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
info->zipFilePtr = z->zipFilePtr;
info->zipEntryPtr = z;
info->numRead = 0;
if (wr) {
flags |= TCL_WRITABLE;
info->isWriting = 1;
info->isDirectory = 0;
info->maxWrite = ZipFS.wrmax;
info->iscompr = 0;
info->isEncrypted = 0;
info->ubuf = (unsigned char *)attemptckalloc(info->maxWrite);
if (!info->ubuf) {
merror0:
if (info->ubuf) {
ckfree(info->ubuf);
}
ckfree(info);
ZIPFS_ERROR(interp, "out of memory");
|
| ︙ | ︙ | |||
3759 3760 3761 3762 3763 3764 3765 |
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
unsigned int j;
stream.avail_in -= 12;
| | | 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 |
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
unsigned int j;
stream.avail_in -= 12;
cbuf = (unsigned char *)attemptckalloc(stream.avail_in);
if (!cbuf) {
goto merror0;
}
for (j = 0; j < stream.avail_in; j++) {
ch = info->ubuf[j];
cbuf[j] = zdecode(info->keys, crc32tab, ch);
}
|
| ︙ | ︙ | |||
3859 3860 3861 3862 3863 3864 3865 |
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (info->isEncrypted) {
stream.avail_in -= 12;
| | | | 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 |
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (info->isEncrypted) {
stream.avail_in -= 12;
ubuf = (unsigned char *)attemptckalloc(stream.avail_in);
if (!ubuf) {
info->ubuf = NULL;
goto merror;
}
for (j = 0; j < stream.avail_in; j++) {
ch = info->ubuf[j];
ubuf[j] = zdecode(info->keys, crc32tab, ch);
}
stream.next_in = ubuf;
} else {
stream.next_in = info->ubuf;
}
stream.next_out = info->ubuf = (unsigned char *)attemptckalloc(info->numBytes);
if (!info->ubuf) {
merror:
if (ubuf) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
ckfree(ubuf);
}
|
| ︙ | ︙ | |||
4147 4148 4149 4150 4151 4152 4153 | * None. * *------------------------------------------------------------------------- */ static Tcl_Obj * ZipFSFilesystemSeparatorProc( | | | 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 |
* None.
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("/", -1);
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4173 4174 4175 4176 4177 4178 4179 | * None. * *------------------------------------------------------------------------- */ static int ZipFSMatchInDirectoryProc( | | | 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMatchInDirectoryProc(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *result,
Tcl_Obj *pathPtr,
const char *pattern,
Tcl_GlobTypeData *types)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
4233 4234 4235 4236 4237 4238 4239 |
l++;
}
if (!pattern || (pattern[0] == '\0')) {
pattern = "*";
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 |
l++;
}
if (!pattern || (pattern[0] == '\0')) {
pattern = "*";
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->mountPointLen == 0) {
ZipEntry *z;
for (z = zf->topEnts; z; z = z->tnext) {
size_t lenz = strlen(z->name);
|
| ︙ | ︙ | |||
4284 4285 4286 4287 4288 4289 4290 |
}
goto end;
}
if (!pattern || (pattern[0] == '\0')) {
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
if (hPtr) {
| | | | | 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 |
}
goto end;
}
if (!pattern || (pattern[0] == '\0')) {
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
if (hPtr) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
|| (dirOnly && z->isDirectory)) {
if (prefix) {
Tcl_DStringAppend(&dsPref, z->name, -1);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
Tcl_DStringLength(&dsPref)));
Tcl_DStringSetLength(&dsPref, prefixLen);
} else {
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(z->name, -1));
}
}
}
goto end;
}
l = strlen(pattern);
pat = (char *)ckalloc(len + l + 2);
memcpy(pat, path, len);
while ((len > 1) && (pat[len - 1] == '/')) {
--len;
}
if ((len > 1) || (pat[0] != '/')) {
pat[len] = '/';
++len;
}
memcpy(pat + len, pattern, l + 1);
scnt = CountSlashes(pat);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
|| (!dirOnly && z->isDirectory))) {
continue;
}
if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
if (prefix) {
|
| ︙ | ︙ | |||
4364 4365 4366 4367 4368 4369 4370 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
| | | 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
TCL_UNUSED(ClientData *))
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int ret = -1;
size_t len;
char *path;
|
| ︙ | ︙ | |||
4393 4394 4395 4396 4397 4398 4399 |
if (hPtr) {
ret = TCL_OK;
goto endloop;
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 |
if (hPtr) {
ret = TCL_OK;
goto endloop;
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->mountPointLen == 0) {
ZipEntry *z;
for (z = zf->topEnts; z != NULL; z = z->tnext) {
size_t lenz = strlen(z->name);
|
| ︙ | ︙ | |||
4460 4461 4462 4463 4464 4465 4466 | * None. * *------------------------------------------------------------------------- */ static const char *const * ZipFSFileAttrStringsProc( | | | > | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static const char *const *
ZipFSFileAttrStringsProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/)
{
static const char *const attrs[] = {
"-uncompsize",
"-compsize",
"-offset",
"-mount",
"-archive",
"-permissions",
NULL,
};
return attrs;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSFileAttrsGetProc --
|
| ︙ | ︙ | |||
4521 4522 4523 4524 4525 4526 4527 |
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
}
switch (index) {
case 0:
| | | | | 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 |
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
}
switch (index) {
case 0:
TclNewIntObj(*objPtrRef, z->numBytes);
break;
case 1:
TclNewIntObj(*objPtrRef, z->numCompressedBytes);
break;
case 2:
TclNewIntObj(*objPtrRef, z->offset);
break;
case 3:
*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
z->zipFilePtr->mountPointLen);
break;
case 4:
*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1);
|
| ︙ | ︙ | |||
4569 4570 4571 4572 4573 4574 4575 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSFileAttrsSetProc(
Tcl_Interp *interp, /* Current interpreter. */
| | | | | 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSFileAttrsSetProc(
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*index*/,
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
TCL_UNUSED(Tcl_Obj *) /*objPtr*/)
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4594 4595 4596 4597 4598 4599 4600 | * Side effects: * *------------------------------------------------------------------------- */ static Tcl_Obj * ZipFSFilesystemPathTypeProc( | | | 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 |
* Side effects:
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("zip", -1);
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4807 4808 4809 4810 4811 4812 4813 |
*/
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
Tcl_NewStringObj("::tcl::zipfs::find", -1));
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
| | | 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 |
*/
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
Tcl_NewStringObj("::tcl::zipfs::find", -1));
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
}
return TCL_OK;
#else /* !HAVE_ZLIB */
ZIPFS_ERROR(interp, "no zlib available");
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
return TCL_ERROR;
#endif /* HAVE_ZLIB */
|
| ︙ | ︙ | |||
4877 4878 4879 4880 4881 4882 4883 4884 4885 |
* Performs the argument munging for the shell
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_AppHook(
int *argcPtr, /* Pointer to argc */
#ifdef _WIN32
| > > > > | | < | | | 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 |
* Performs the argument munging for the shell
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_AppHook(
#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
int *argcPtr, /* Pointer to argc */
#else
TCL_UNUSED(int *), /*argcPtr*/
#endif
#ifdef _WIN32
TCL_UNUSED(WCHAR ***)) /* argvPtr */
#else /* !_WIN32 */
char ***argvPtr) /* Pointer to argv */
#endif /* _WIN32 */
{
char *archive;
#ifdef _WIN32
Tcl_FindExecutable(NULL);
#else
Tcl_FindExecutable((*argvPtr)[0]);
#endif
archive = (char *) Tcl_GetNameOfExecutable();
TclZipfs_Init(NULL);
/*
* Look for init.tcl in one of the locations mounted later in this
* function.
*/
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
1 2 3 4 5 | /* * tclZlib.c -- * * This file provides the interface to the Zlib library. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclZlib.c -- * * This file provides the interface to the Zlib library. * * Copyright © 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright © 2005 Unitas Software B.V. * Copyright © 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * 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. */ |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
| | < > > | | | > > | | 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 |
int mode; /* Either the value TCL_ZLIB_STREAM_DEFLATE
* for compression on output, or
* TCL_ZLIB_STREAM_INFLATE for decompression
* on input. */
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
unsigned int readAheadLimit;/* The maximum number of bytes to read from
* the underlying stream in one go. */
z_stream inStream; /* Structure used by zlib for decompression of
* input. */
z_stream outStream; /* Structure used by zlib for compression of
* output. */
char *inBuffer, *outBuffer; /* Working buffers. */
size_t inAllocated, outAllocated;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
GzipHeader outHeader; /* Header to write to an output stream, when
* compressing a gzip stream. */
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 flags field. Definitions are:
* ASYNC - Whether this is an asynchronous channel.
* IN_HEADER - Whether the inHeader field has been registered with
* the input compressor.
* OUT_HEADER - Whether the outputHeader field has been registered
* with the output decompressor.
* STREAM_DECOMPRESS - Signal decompress pending data.
* STREAM_DONE - Flag to signal stream end up to transform input.
*/
#define ASYNC 0x01
#define IN_HEADER 0x02
#define OUT_HEADER 0x04
#define STREAM_DECOMPRESS 0x08
#define STREAM_DONE 0x10
/*
* 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.
*/
#define DEFAULT_BUFFER_SIZE 4096
#define MIN_NONSTREAM_BUFFER_SIZE 16
#define MAX_BUFFER_SIZE 65536
/*
* Prototypes for private procedures defined later in this file:
*/
static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
static Tcl_DriverClose2Proc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
static Tcl_DriverHandlerProc ZlibTransformEventHandler;
static Tcl_DriverInputProc ZlibTransformInput;
static Tcl_DriverOutputProc ZlibTransformOutput;
static Tcl_DriverSetOptionProc ZlibTransformSetOption;
static Tcl_DriverWatchProc ZlibTransformWatch;
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 | static inline int Deflate(z_streamp strm, void *bufferPtr, int bufferSize, int flush, int *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[]); | | < < | | | | 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 |
static inline int Deflate(z_streamp strm, void *bufferPtr,
int bufferSize, int flush, int *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 *cd, 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 *cd);
static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
*/
static const Tcl_ChannelType zlibChannelType = {
"zlib",
TCL_CHANNEL_VERSION_5,
TCL_CLOSE2PROC,
ZlibTransformInput,
ZlibTransformOutput,
NULL, /* seekProc */
ZlibTransformSetOption,
ZlibTransformGetOption,
ZlibTransformWatch,
ZlibTransformGetHandle,
ZlibTransformClose, /* close2Proc */
ZlibTransformBlockMode,
NULL, /* flushProc */
ZlibTransformEventHandler,
NULL, /* wideSeekProc */
NULL,
NULL
};
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
return Tcl_NewListObj(3, objv);
case Z_ERRNO:
TclNewLiteralStringObj(objv[2], "POSIX");
objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
return Tcl_NewListObj(4, objv);
case Z_NEED_DICT:
TclNewLiteralStringObj(objv[2], "NEED_DICT");
| | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
return Tcl_NewListObj(3, objv);
case Z_ERRNO:
TclNewLiteralStringObj(objv[2], "POSIX");
objv[3] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
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!
*/
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
| | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
if (GenerateHeader(interp, dictObj, gzHeaderPtr,
NULL) != TCL_OK) {
ckfree(gzHeaderPtr);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
| | | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
gzHeaderPtr = (GzipHeader *)ckalloc(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;
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
| | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
zshPtr = (ZlibStreamHandle *)ckalloc(sizeof(ZlibStreamHandle));
zshPtr->interp = interp;
zshPtr->mode = mode;
zshPtr->format = format;
zshPtr->level = level;
zshPtr->wbits = wbits;
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *cd)
{
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *cd)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
zshPtr->cmd = NULL;
ZlibStreamCleanup(zshPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
| > > > > > | 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL,
compressionDictionaryObj, NULL))) {
/* Missing or invalid compression dictionary */
compressionDictionaryObj = NULL;
}
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
Tcl_Obj *data, /* Data to compress/decompress */
int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
* TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize, toStore;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
| > > > > > > | | 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 |
Tcl_Obj *data, /* Data to compress/decompress */
int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
* TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize, toStore;
unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
bytes = TclGetBytesFromObj(zshPtr->interp, data, &size);
if (bytes == NULL) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
zshPtr->stream.next_in = bytes;
zshPtr->stream.avail_in = size;
/*
* Must not do a zero-length compress unless finalizing. [Bug 25842c161]
*/
if (size == 0 && flush != Z_FINISH) {
|
| ︙ | ︙ | |||
1229 1230 1231 1232 1233 1234 1235 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
| | | 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
dataTmp = (char *)ckalloc(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
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
| | | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 |
*/
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 *)ckrealloc(dataTmp, outSize);
}
}
/*
* And append the final data block to the outData list.
*/
|
| ︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 |
* Getting beyond the of stream, just return empty string.
*/
if (zshPtr->streamEnd) {
return TCL_OK;
}
| | > > | 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 |
* Getting beyond the of stream, just return empty string.
*/
if (zshPtr->streamEnd) {
return TCL_OK;
}
if (NULL == TclGetBytesFromObj(zshPtr->interp, data, &existing)) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
/*
* The only safe thing to do is restict to 65k. We might cause a
* panic for out of memory if we just kept growing the buffer.
*/
|
| ︙ | ︙ | |||
1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 |
GzipHeader header;
gz_header *headerPtr = NULL;
Tcl_Obj *obj;
if (!interp) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
if (format == TCL_ZLIB_FORMAT_RAW) {
| > > > > > > > > > > | 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
GzipHeader header;
gz_header *headerPtr = NULL;
Tcl_Obj *obj;
if (!interp) {
return TCL_ERROR;
}
/*
* Obtain the pointer to the byte array, we'll pass this pointer straight
* to the deflate command.
*/
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
if (format == TCL_ZLIB_FORMAT_RAW) {
|
| ︙ | ︙ | |||
1613 1614 1615 1616 1617 1618 1619 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
| < < < < < < | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = (uInt) inLen;
stream.next_in = inData;
/*
* No output buffer available yet, will alloc after deflateInit2.
*/
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 |
gz_header header, *headerPtr = NULL;
Tcl_Obj *obj;
char *nameBuf = NULL, *commentBuf = NULL;
if (!interp) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
switch (format) {
| > > > > > | 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 |
gz_header header, *headerPtr = NULL;
Tcl_Obj *obj;
char *nameBuf = NULL, *commentBuf = NULL;
if (!interp) {
return TCL_ERROR;
}
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
switch (format) {
|
| ︙ | ︙ | |||
1748 1749 1750 1751 1752 1753 1754 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
| | | < | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 |
"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 *)ckalloc(MAXPATHLEN);
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = (char *)ckalloc(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;
|
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 | * Implementation of the [zlib] command. * *---------------------------------------------------------------------- */ static int ZlibCmd( | | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 |
* Implementation of the [zlib] command.
*
*----------------------------------------------------------------------
*/
static int
ZlibCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int command, dlen, i, option, level = -1;
unsigned start, buffersize = 0;
Byte *data;
|
| ︙ | ︙ | |||
1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
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);
}
| > > > > < > > > > < | 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 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = TclGetBytesFromObj(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_WideInt)
(uLong) 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 = TclGetBytesFromObj(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_WideInt)
(uLong) 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?");
|
| ︙ | ︙ | |||
2130 2131 2132 2133 2134 2135 2136 |
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
break;
case 1:
headerVarObj = objv[i+1];
| | | 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 |
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
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);
|
| ︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
| > > > > > > | 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
if (compDictObj) {
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
return TCL_ERROR;
}
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
|
| ︙ | ︙ | |||
2360 2361 2362 2363 2364 2365 2366 |
static const char *const pushCompressOptions[] = {
"-dictionary", "-header", "-level", NULL
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
| | | | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 |
static const char *const pushCompressOptions[] = {
"-dictionary", "-header", "-level", NULL
};
static const char *const pushDecompressOptions[] = {
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = DEFAULT_BUFFER_SIZE, dummy;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0,
|
| ︙ | ︙ | |||
2442 2443 2444 2445 2446 2447 2448 |
}
if (++i > objc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value missing for %s option", pushOptions[option]));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
| | | 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
}
if (++i > objc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value missing for %s option", pushOptions[option]));
Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
return TCL_ERROR;
}
switch ((enum pushOptionsEnum) option) {
case poHeader:
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
goto genericOptionError;
}
break;
case poLevel:
|
| ︙ | ︙ | |||
2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
| > > > > | 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, NULL))) {
return TCL_ERROR;
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
|
| ︙ | ︙ | |||
2517 2518 2519 2520 2521 2522 2523 |
static int
ZlibStreamCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 |
static int
ZlibStreamCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int command, count, code;
Tcl_Obj *obj;
static const char *const cmds[] = {
"add", "checksum", "close", "eof", "finalize", "flush",
"fullflush", "get", "header", "put", "reset",
NULL
};
|
| ︙ | ︙ | |||
2643 2644 2645 2646 2647 2648 2649 |
static int
ZlibStreamAddCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | | | | 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 |
static int
ZlibStreamAddCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int index, 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
};
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum addOptions) 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 */
if (i == objc-2) {
|
| ︙ | ︙ | |||
2731 2732 2733 2734 2735 2736 2737 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
| > > > | | 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
|
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 |
static int
ZlibStreamPutCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | | | | 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 |
static int
ZlibStreamPutCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int index, 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
};
for (i=2; i<objc-1; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum putOptions) 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:
if (i == objc-2) {
|
| ︙ | ︙ | |||
2835 2836 2837 2838 2839 2840 2841 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
| | > > | | 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 |
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
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 *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
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) {
|
| ︙ | ︙ | |||
2891 2892 2893 2894 2895 2896 2897 |
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
| | > | > > > > | 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 |
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
Tcl_Interp *interp,
int flags)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
int e, written, result = TCL_OK;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Delete the support timer.
*/
ZlibTransformEventTimerKill(cd);
|
| ︙ | ︙ | |||
2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 |
}
result = TCL_ERROR;
break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->outStream);
} else {
(void) inflateEnd(&cd->inStream);
}
/*
* Release all memory.
*/
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
| > > > > > > > > > < | 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 |
}
result = TCL_ERROR;
break;
}
} while (e != Z_STREAM_END);
(void) deflateEnd(&cd->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 (cd->inStream.avail_in) {
Tcl_Ungets (cd->parent, (char *)cd->inStream.next_in, cd->inStream.avail_in, 0);
}
(void) inflateEnd(&cd->inStream);
}
/*
* Release all memory.
*/
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
if (cd->inBuffer) {
ckfree(cd->inBuffer);
cd->inBuffer = NULL;
}
if (cd->outBuffer) {
ckfree(cd->outBuffer);
|
| ︙ | ︙ | |||
2986 2987 2988 2989 2990 2991 2992 |
static int
ZlibTransformInput(
void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | > | < | < < < < < < | | > | > > > > > > | | < | > | | | > | > > | > > > | | > | > | | | < > > > > > | | > > | > | | | < < < < < > > < < | < < < > > > > > > > | < | > | > > > > > > | | 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 |
static int
ZlibTransformInput(
void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
int readBytes, gotBytes;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
errorCodePtr);
}
gotBytes = 0;
readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */
while (!(cd->flags & STREAM_DONE) && toRead > 0) {
unsigned int n; int decBytes;
/* if starting from scratch or continuation after full decompression */
if (!cd->inStream.avail_in) {
/* buffer to start, we can read to whole available buffer */
cd->inStream.next_in = (Bytef *) cd->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 (cd->flags & 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 = cd->inAllocated - ((char *)cd->inStream.next_in - cd->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 > cd->readAheadLimit) {
n = cd->readAheadLimit;
}
readBytes = Tcl_ReadRaw(cd->parent, (char *)cd->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 < 0) 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 < 0) {
/* See ReflectInput() in tclIORTrans.c */
if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) {
break;
}
*errorCodePtr = Tcl_GetErrno();
return -1;
}
/* more bytes (or Eof if readBytes == 0) */
cd->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(cd, 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) || (cd->flags & STREAM_DECOMPRESS))) {
/*
* The drain delivered nothing (or buffer too small to decompress).
* Time to deliver what we've got.
*/
if (!gotBytes && !(cd->flags & STREAM_DONE)) {
/* if no-data, but not ready - avoid signaling Eof,
* continue in blocking mode, otherwise EAGAIN */
if (Tcl_InputBlocked(cd->parent)) {
continue;
}
*errorCodePtr = EAGAIN;
return -1;
}
break;
}
/*
* Loop until the request is satisfied (or no data available from
* above, possibly EOF).
*/
}
return gotBytes;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformOutput --
*
* Writer filter that does compression.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverOutputProc *outProc =
Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent));
int e, produced;
Tcl_Obj *errObj;
if (cd->mode == TCL_ZLIB_STREAM_INFLATE) {
return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
|
| ︙ | ︙ | |||
3221 3222 3223 3224 3225 3226 3227 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
| | > | > > | 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 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverSetOptionProc *setOptionProc =
Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->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 = (cd->mode == TCL_ZLIB_STREAM_DEFLATE);
if (optionName && (strcmp(optionName, "-dictionary") == 0)
&& (cd->format != TCL_ZLIB_FORMAT_GZIP)) {
Tcl_Obj *compDictObj;
int code;
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
Tcl_DecrRefCount(compDictObj);
return TCL_ERROR;
}
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
cd->compDictObj = compDictObj;
code = Z_OK;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&cd->outStream, compDictObj);
|
| ︙ | ︙ | |||
3334 3335 3336 3337 3338 3339 3340 |
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
| | | 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 |
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->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";
|
| ︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 |
/*
* 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 ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
| | > | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 |
/*
* 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 ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
Tcl_Obj *tmpObj;
TclNewObj(tmpObj);
ExtractHeader(&cd->inHeader.header, tmpObj);
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-header");
Tcl_DStringAppendElement(dsPtr, Tcl_GetString(tmpObj));
Tcl_DecrRefCount(tmpObj);
} else {
TclDStringAppendObj(dsPtr, tmpObj);
|
| ︙ | ︙ | |||
3452 3453 3454 3455 3456 3457 3458 |
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
| | | | | | 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 |
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverWatchProc *watchProc;
/*
* This code is based on the code in tclIORTrans.c
*/
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
watchProc(Tcl_GetChannelInstanceData(cd->parent), mask);
if (!(mask & TCL_READABLE) || !(cd->flags & STREAM_DECOMPRESS)) {
ZlibTransformEventTimerKill(cd);
} else if (cd->timer == NULL) {
cd->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ZlibTransformTimerRun, cd);
}
}
static int
ZlibTransformEventHandler(
void *instanceData,
int interestMask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
ZlibTransformEventTimerKill(cd);
return interestMask;
}
static inline void
ZlibTransformEventTimerKill(
ZlibChannelData *cd)
{
if (cd->timer != NULL) {
Tcl_DeleteTimerHandler(cd->timer);
cd->timer = NULL;
}
}
static void
ZlibTransformTimerRun(
void *clientData)
{
ZlibChannelData *cd = (ZlibChannelData *)clientData;
cd->timer = NULL;
Tcl_NotifyChannel(cd->chan, TCL_READABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3518 3519 3520 3521 3522 3523 3524 |
static int
ZlibTransformGetHandle(
void *instanceData,
int direction,
void **handlePtr)
{
| | | | 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 |
static int
ZlibTransformGetHandle(
void *instanceData,
int direction,
void **handlePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
return Tcl_GetChannelHandle(cd->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 *cd = (ZlibChannelData *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
cd->flags |= ASYNC;
} else {
cd->flags &= ~ASYNC;
}
return TCL_OK;
|
| ︙ | ︙ | |||
3588 3589 3590 3591 3592 3593 3594 |
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. */
{
| | | 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 |
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 *cd = (ZlibChannelData *)ckalloc(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);
}
|
| ︙ | ︙ | |||
3648 3649 3650 3651 3652 3653 3654 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
| > > > | | < < | 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 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
if (cd->inAllocated < cd->readAheadLimit) {
cd->inAllocated = cd->readAheadLimit;
}
cd->inBuffer = (char *)ckalloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) {
goto error;
}
}
if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) {
if (SetInflateDictionary(&cd->inStream, cd->compDictObj) != Z_OK) {
goto error;
}
}
} else {
if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) {
goto error;
}
cd->outAllocated = DEFAULT_BUFFER_SIZE;
cd->outBuffer = (char *)ckalloc(cd->outAllocated);
if (cd->flags & OUT_HEADER) {
if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) {
goto error;
}
}
if (cd->compDictObj) {
if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) {
goto error;
}
}
}
chan = Tcl_StackChannel(interp, &zlibChannelType, cd,
Tcl_GetChannelMode(channel), channel);
if (chan == NULL) {
goto error;
}
cd->chan = chan;
cd->parent = Tcl_GetStackedChannel(chan);
|
| ︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 |
ckfree(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < > > | > | < < | < < < > | | > < < < | | < < < < | > > > > | > > > > > | > > > > > | > > > > > > > | | 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 |
ckfree(cd);
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 cd->inStream (next_in, avail_in) to reflect
* the data that has been decompressed.
*
*----------------------------------------------------------------------
*/
static int
ResultDecompress(
ZlibChannelData *cd,
char *buf,
int toRead,
int flush,
int *errorCodePtr)
{
int e, written, resBytes = 0;
Tcl_Obj *errObj;
cd->flags &= ~STREAM_DECOMPRESS;
cd->inStream.next_out = (Bytef *) buf;
cd->inStream.avail_out = toRead;
while (cd->inStream.avail_out > 0) {
e = inflate(&cd->inStream, flush);
if (e == Z_NEED_DICT && cd->compDictObj) {
e = SetInflateDictionary(&cd->inStream, cd->compDictObj);
if (e == Z_OK) {
/*
* A repetition of Z_NEED_DICT is just an error.
*/
e = inflate(&cd->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 - cd->inStream.avail_out;
/*
* The cases where we're definitely done.
*/
if (e == Z_STREAM_END) {
cd->flags |= STREAM_DONE;
resBytes += written;
break;
}
if (e == Z_OK) {
if (written == 0) {
break;
}
resBytes += written;
}
if ((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) {
break;
}
/*
* Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
*
* Just indicates that the zlib couldn't consume input/produce output,
* and is fixed by supplying more input.
*
* Otherwise, we've got errors and need to report to higher-up.
*/
if ((e != Z_OK) && (e != Z_BUF_ERROR)) {
goto handleError;
}
/*
* Check if the inflate stopped early.
*/
if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) {
break;
}
}
if (!(cd->flags & STREAM_DONE)) {
/* if we have pending input data, but no available output buffer */
if (cd->inStream.avail_in && !cd->inStream.avail_out) {
/* next time try to decompress it got readable (new output buffer) */
cd->flags |= STREAM_DECOMPRESS;
}
}
return resBytes;
handleError:
errObj = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, errObj, Tcl_NewStringObj("-errorcode",-1));
Tcl_ListObjAppendElement(NULL, errObj,
ConvertErrorToList(e, cd->inStream.adler));
Tcl_ListObjAppendElement(NULL, errObj,
Tcl_NewStringObj(cd->inStream.msg, -1));
Tcl_SetChannelError(cd->parent, errObj);
*errorCodePtr = EINVAL;
return -1;
}
/*
*----------------------------------------------------------------------
* Finally, the TclZlibInit function. Used to install the zlib API.
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
3904 3905 3906 3907 3908 3909 3910 |
* TODO: Describe whether we're using the system version of the library or
* a compatibility version built into Tcl?
*/
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
| | > | > > | 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 |
* TODO: Describe whether we're using the system version of the library or
* a compatibility version built into Tcl?
*/
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
Tcl_RegisterConfig(interp, "zlib", cfg, "utf-8");
/*
* Allow command type introspection to do something sensible with streams.
*/
TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
/*
* Formally provide the package as a Tcl built-in.
*/
#ifndef TCL_NO_DEPRECATED
Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
#endif
return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION);
}
/*
*----------------------------------------------------------------------
* Stubs used when a suitable zlib installation was not found during
* configure.
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to library/auto.tcl.
1 2 3 4 5 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution of commands # and can be auto loaded themselves. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution of commands # and can be auto loaded themselves. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # # auto_reset -- # |
| ︙ | ︙ | |||
261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
cd $oldDir
return -options $opts $msg
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source code for
# "proc" at the beginning of the line.
| > | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
cd $oldDir
return -options $opts $msg
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
fconfigure $fid -encoding utf-8 -translation lf
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source code for
# "proc" at the beginning of the line.
|
| ︙ | ︙ | |||
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 |
if {![llength $args]} {
set args *.tcl
}
foreach file [lsort [glob -- {*}$args]] {
set f ""
set error [catch {
set f [open $file]
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 \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
return -options $opts $msg
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
| > > | 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 |
if {![llength $args]} {
set args *.tcl
}
foreach file [lsort [glob -- {*}$args]] {
set f ""
set error [catch {
set f [open $file]
fconfigure $f -encoding utf-8 -eofchar \032
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 \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
return -options $opts $msg
}
}
set f ""
set error [catch {
set f [open tclIndex w]
fconfigure $f -encoding utf-8 -translation lf
puts -nonewline $f $index
close $f
cd $oldDir
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe interpreter:
# references like "$x" will fail since code is not really being executed
# and variables do not really exist. To avoid this, we replace all $ with
# \0 (literally, the null char) later, when getting proc names we will
| > | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
fconfigure $fid -encoding utf-8 -eofchar \032
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe interpreter:
# references like "$x" will fail since code is not really being executed
# and variables do not really exist. To avoid this, we replace all $ with
# \0 (literally, the null char) later, when getting proc names we will
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
| | | | | | | | | | 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 |
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the child interpreter
# used by the mkindex parser. The command is evaluated in the parent
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
# the child
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::childhook command
#
# Registers a Tcl command to evaluate when initializing the child interpreter
# used by the mkindex parser. The command is evaluated in the child
# interpreter.
proc auto_mkindex_parser::childhook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the child interpreter
# when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
auto_mkindex_parser::command proc {name args} {
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
| | | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
auto_mkindex_parser::command proc {name args} {
indexEntry $name
}
# Conditionally add support for Tcl byte code files. There are some tricky
# details here. First, we need to get the tbcload library initialized in the
# current interpreter. We cannot load tbcload into the child until we have
# done so because it needs access to the tcl_patchLevel variable. Second,
# because the package index file may defer loading the library until we invoke
# a command, we need to explicitly invoke auto_load to force it to be loaded.
# This should be a noop if the package has already been loaded
auto_mkindex_parser::hook {
try {
|
| ︙ | ︙ |
Changes to library/clock.tcl.
1 2 3 4 5 6 7 8 9 10 11 | #---------------------------------------------------------------------- # # 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. # # #---------------------------------------------------------------------- # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | #---------------------------------------------------------------------- # # 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. # #---------------------------------------------------------------------- # We must have message catalogs that support the root locale, and we need # access to the Registry on Windows systems. |
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 |
variable DataDir
variable TZData
if { [info exists TZData($fileName)] } {
return
}
| | | | 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 |
variable DataDir
variable TZData
if { [info exists TZData($fileName)] } {
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 {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $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] \
"time zone \":$fileName\" not found"
}
return
}
|
| ︙ | ︙ | |||
3340 3341 3342 3343 3344 3345 3346 |
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
| | | 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 |
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
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 {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
|
| ︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 |
# arbitrary start time in front of the transitions.
binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
incr seek [expr { ($ilen + 1) * $nTime }]
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
| | | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 |
# arbitrary start time in front of the transitions.
binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
incr seek [expr { ($ilen + 1) * $nTime }]
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
lappend codes [expr { $c & 0xFF }]
}
set codes [linsert $codes 0 0]
# Next come ${nType} time type descriptions, each of which has an offset
# (seconds east of GMT), a DST indicator, and an index into the
# abbreviation text.
|
| ︙ | ︙ |
Changes to library/cookiejar/cookiejar.tcl.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
lappend result [join [lrange $pieces $i end] "."]
}
return $result
}
proc splitPath path {
set pieces [split [string trimleft $path "/"] "/"]
| > | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
lappend result [join [lrange $pieces $i end] "."]
}
return $result
}
proc splitPath path {
set pieces [split [string trimleft $path "/"] "/"]
set result /
for {set j 0} {$j < [llength $pieces]} {incr j} {
lappend result /[join [lrange $pieces 0 $j] "/"]
}
return $result
}
proc isoNow {} {
set ms [clock milliseconds]
set ts [expr {$ms / 1000}]
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
# Now we have enough information to provide the package.
package provide cookiejar \
[set [info object namespace ::http::cookiejar]::version]
# The implementation of the cookiejar package
::oo::define ::http::cookiejar {
self {
| | | | | 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 |
# Now we have enough information to provide the package.
package provide cookiejar \
[set [info object namespace ::http::cookiejar]::version]
# The implementation of the cookiejar package
::oo::define ::http::cookiejar {
self {
method configure {{optionName "\x00\x00"} {optionValue "\x00\x00"}} {
set tbl {
-domainfile {domainfile set}
-domainlist {domainlist set}
-domainrefresh {refreshinterval setInterval}
-loglevel {loglevel setLog}
-offline {offline setBool}
-purgeold {purgeinterval setInterval}
-retain {retainlimit setInt}
-vacuumtrigger {vacuumtrigger setInt}
}
dict lappend tbl -domainrefresh [namespace code {
my IntervalTrigger PostponeRefresh
}]
dict lappend tbl -purgeold [namespace code {
my IntervalTrigger PostponePurge
}]
if {$optionName eq "\x00\x00"} {
return [dict keys $tbl]
}
set opt [::tcl::prefix match -message "option" \
[dict keys $tbl] $optionName]
set setter [lassign [dict get $tbl $opt] varname]
namespace upvar [namespace current] $varname var
if {$optionValue ne "\x00\x00"} {
{*}$setter var $optionValue
}
return $var
}
method IntervalTrigger {method} {
# TODO: handle subclassing
|
| ︙ | ︙ |
Changes to library/cookiejar/idna.tcl.
1 2 3 4 5 6 7 8 9 | # cookiejar.tcl -- # # Implementation of IDNA (Internationalized Domain Names for # Applications) encoding/decoding system, built on a punycode engine # developed directly from the code in RFC 3492, Appendix C (with # substantial modifications). # # This implementation includes code from that RFC, translated to Tcl; the # other parts are: | | | | | 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 |
# cookiejar.tcl --
#
# Implementation of IDNA (Internationalized Domain Names for
# Applications) encoding/decoding system, built on a punycode engine
# developed directly from the code in RFC 3492, Appendix C (with
# substantial modifications).
#
# This implementation includes code from that RFC, translated to Tcl; the
# other parts are:
# Copyright © 2014 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval ::tcl::idna {
namespace ensemble create -command puny -map {
encode punyencode
decode punydecode
}
namespace ensemble create -command ::tcl::idna -map {
encode IDNAencode
decode IDNAdecode
puny puny
version {::apply {{} {package present tcl::idna} ::}}
}
proc IDNAencode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] {
if {[regexp {[^-A-Za-z0-9]} $part]} {
if {[regexp {[^-A-Za-z0-9\xA1-\uFFFF]} $part ch]} {
scan $ch %c c
if {$ch < "!" || $ch > "~"} {
set ch [format "\\u%04x" $c]
}
throw [list IDNA INVALID_NAME_CHARACTER $ch] \
"bad character \"$ch\" in DNS name"
}
|
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
lappend parts $part
}
return [join $parts .]
}
proc IDNAdecode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
lappend parts $part
}
return [join $parts .]
}
proc IDNAdecode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] {
if {[string match -nocase "xn--*" $part]} {
set part [punydecode [string range $part 4 end]]
}
lappend parts $part
}
return [join $parts .]
}
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
# Initialize the state:
set n $initial_n
set delta 0
set bias $initial_bias
# Handle the basic code points:
foreach ch $string {
| | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
# Initialize the state:
set n $initial_n
set delta 0
set bias $initial_bias
# Handle the basic code points:
foreach ch $string {
if {$ch < "\x80"} {
if {$case eq ""} {
append output $ch
} elseif {[string is true $case]} {
append output [string toupper $ch]
} elseif {[string is false $case]} {
append output [string tolower $ch]
}
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | set m $ch } } # Increase delta enough to advance the decoder's <n,i> state to # <m,0>, but guard against overflow: | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
set m $ch
}
}
# Increase delta enough to advance the decoder's <n,i> state to
# <m,0>, but guard against overflow:
if {$m-$n > (0xFFFFFFFF-$delta)/($h+1)} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
incr delta [expr {($m-$n) * ($h+1)}]
set n $m
foreach ch $in {
if {$ch < $n && ([incr delta] & 0xFFFFFFFF) == 0} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
if {$ch != $n} {
continue
}
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
| | | | | 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 |
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
if {[set w [expr {$w * ($base - $t)}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in digit decode"
}
incr k $base
}
# i was supposed to wrap around from out+1 to 0, incrementing n
# each time, so we'll fix that now:
if {[incr n [expr {$i / $out}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in character choice"
} elseif {$n > $max_codepoint} {
if {$n >= 0x00D800 && $n < 0x00E000} {
# Bare surrogate?!
throw {PUNYCODE NON_BMP} \
[format "unsupported character U+%06x" $n]
}
throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
}
set i [expr {$i % $out}]
|
| ︙ | ︙ |
Changes to library/dde/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
| < | < < < | 1 2 3 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll]]
|
Changes to library/history.tcl.
1 2 3 4 | # history.tcl -- # # Implementation of the history command. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # history.tcl -- # # Implementation of the history command. # # Copyright © 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. # # The tcl::history array holds the history list and some additional # bookkeeping variables. |
| ︙ | ︙ |
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.0a1
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set connId $state(socketinfo)
}
} else {
set map [array get socketMapping]
set ndx [lsearch -exact $map $s]
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
upvar 0 $token state
if {[info exists state(socketinfo)]} {
set connId $state(socketinfo)
}
} else {
set map [array get socketMapping]
set ndx [lsearch -exact $map $s]
if {$ndx >= 0} {
incr ndx -1
set connId [lindex $map $ndx]
}
}
if { ($connId ne {})
&& [info exists socketMapping($connId)]
&& ($socketMapping($connId) eq $s)
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
| | > < | | | 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 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
connection keep-alive
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-strict boolean
-timeout integer
-validate boolean
-headers dict
}
set state(charset) $defaultCharset
set options {
-binary -blocksize -channel -command -handler -headers -keepalive
-method -myaddr -progress -protocol -query -queryblocksize
-querychannel -queryprogress -strict -timeout -type -validate
}
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 {($flag eq "-headers") ? [catch {dict size $value}] :
([info exists type($flag)] && ![string is $type($flag) -strict $value])
} {
unset $token
return -code error \
"Bad value for $flag ($value), must be $type($flag)"
}
set state($flag) $value
} else {
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
# There is a small risk of a race against server timeout.
set state(-pipeline) 0
}
} else {
# It's a GET or HEAD.
set state(-pipeline) $http(-pipeline)
}
# See if we are supposed to use a previously opened channel.
# - In principle, ANY call to http::geturl could use a previously opened
# channel if it is available - the "Connection: keep-alive" header is a
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
| > > > > > > > > > > > > | 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 |
# There is a small risk of a race against server timeout.
set state(-pipeline) 0
}
} else {
# It's a GET or HEAD.
set state(-pipeline) $http(-pipeline)
}
# We cannot handle chunked encodings with -handler, so force HTTP/1.0
# until we can manage this.
if {[info exists state(-handler)]} {
set state(-protocol) 1.0
}
# RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it.
if {$state(-protocol) eq "1.0"} {
set state(connection) close
set state(-keepalive) 0
}
# See if we are supposed to use a previously opened channel.
# - In principle, ANY call to http::geturl could use a previously opened
# channel if it is available - the "Connection: keep-alive" header is a
# request to leave the channel open AFTER completion of this call.
# - In fact, we try to use an existing channel only if -keepalive 1 -- this
# means that at most one channel is left open for each value of
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 | # is handled by socketWrQueue later in this command. set reusing 1 set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" } # Do not automatically close the connection socket. | | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
# is handled by socketWrQueue later in this command.
set reusing 1
set sock $socketMapping($state(socketinfo))
Log "reusing socket $sock for $state(socketinfo) - token $token"
}
# Do not automatically close the connection socket.
set state(connection) keep-alive
}
}
if {$reusing} {
# Define state(tmpState) and state(tmpOpenCmd) for use
# by http::ReplayIfDead if the persistent connection has died.
set state(tmpState) [array get state]
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
| < | < < < < < < | 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
set accept_types_seen 0
Log ^B$tk begin sending request - token $token
if {[catch {
set state(method) $how
puts $sock "$how $srvurl HTTP/$state(-protocol)"
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
set state(host) $host
puts $sock "Host: $host"
} else {
set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
| | > > > > > > | | > > | 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 |
set state(host) $host
puts $sock "Host: $host"
} else {
set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
if {($state(-protocol) > 1.0) && $state(-keepalive)} {
# Send this header, because a 1.1 server is not compelled to treat
# this as the default.
puts $sock "Connection: keep-alive"
}
if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
}
if {($state(-protocol) < 1.1)} {
# RFC7230 A.1
# 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".
puts $sock "Connection: close"
}
# 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
dict for {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string map {" " -} [string trim $key]]
if {[string equal -nocase $key "host"]} {
continue
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
Log ^D$tk begin receiving response - token $token
coroutine ${token}EventCoroutine http::Event $sock $token
| > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
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
#
# Bug [c2dc1da315].
# - Recursive launch of the coroutine can occur if a -handler or -progress
# callback is used, and the callback command enters the event loop.
# - To prevent this, the fileevent "binding" is disabled while the
# coroutine is in flight.
# - If a recursive call occurs despite these precautions, it is not
# trapped and discarded here, because it is better to report it as a
# bug.
# - Although this solution is believed to be sufficiently general, it is
# used only if -handler or -progress is specified. In other cases,
# the coroutine is called directly.
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::make-transformation-chunked.
#
# 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
}
# http::NextPipelinedWrite
#
# - Connecting a socket to a token for writing is done by this command and by
# command KeepSocket.
# - If another request has a pipelined write scheduled for $token's socket,
# and if the socket is ready to accept it, connect the write and update
|
| ︙ | ︙ | |||
2723 2724 2725 2726 2727 2728 2729 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
| > > > > > > > > > > > > > > > > > > > > > > > > > | < | 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 |
}
transfer-encoding {
set state(transfer) \
[string trim [string tolower $value]]
}
proxy-connection -
connection {
set tmpHeader [string trim [string tolower $value]]
# RFC 7230 Section 6.1 states that a comma-separated
# list is an acceptable value. According to
# https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection
# any comma-separated list implies keep-alive, but I
# don't see this in the RFC so we'll play safe and
# scan any list for "close".
if {$tmpHeader in {close keep-alive}} {
# The common cases, continue.
} elseif {[string first , $tmpHeader] < 0} {
# Not a comma-separated list, not "close",
# therefore "keep-alive".
set tmpHeader keep-alive
} else {
set tmpResult keep-alive
set tmpCsl [split $tmpHeader ,]
# Optional whitespace either side of separator.
foreach el $tmpCsl {
if {[string trim $el] eq {close}} {
set tmpResult close
break
}
}
set tmpHeader $tmpResult
}
set state(connection) $tmpHeader
}
set-cookie {
if {$http(-cookiejar) ne ""} {
ParseCookie $token [string trim $value]
}
}
}
|
| ︙ | ︙ | |||
3161 3162 3163 3164 3165 3166 3167 |
# Empty line is not distinguished from eof. The caller must
# be able to handle this.
proc http::BlockingGets {sock} {
while 1 {
set count [gets $sock line]
set eof [eof $sock]
| | | 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 |
# Empty line is not distinguished from eof. The caller must
# be able to handle this.
proc http::BlockingGets {sock} {
while 1 {
set count [gets $sock line]
set eof [eof $sock]
if {$count >= 0 || $eof} {
return $line
} else {
yield
}
}
}
|
| ︙ | ︙ |
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.0a1 [list tclPkgSetup $dir http 2.10.0a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
1 2 3 4 5 | # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # | | | | | | | | > > > > | > | | < < < < < < < < < < < > > > > > > > > > > > | < | | | | > | 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 |
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2004 Kevin B. Kenny.
# Copyright © 2018 Sean Woods
#
# All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact tcl 8.7a4
# 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.
# [tclInit] (Tcl_Init()) searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory ../lib relative to the directory where the
# executable is located. This is meant to find binary packages for the
# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
#
# (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 $env(TCLLIBPATH)
} 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
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} { catch {
foreach Dir $::tcl_pkgPath {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
}}
variable Path [encoding dirs]
set Dir [file join $::tcl_library encoding]
if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
}
unset Dir Path
}
}
namespace eval tcl::Pkg {}
# Setup the unknown package handler
|
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
proc ::tcl::initClock {} {
# Auto-loading stubs for 'clock.tcl'
foreach cmd {add format scan} {
proc ::tcl::clock::$cmd args {
variable TclLibDir
| | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
proc ::tcl::initClock {} {
# Auto-loading stubs for 'clock.tcl'
foreach cmd {add format scan} {
proc ::tcl::clock::$cmd args {
variable TclLibDir
source [file join $TclLibDir clock.tcl]
return [uplevel 1 [info level 0]]
}
}
rename ::tcl::initClock {}
}
::tcl::initClock
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
if {$last + [string length $tail] != [string length $errInfo]} {
# Very likely cannot happen
return -options $opts $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
| | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
if {$last + [string length $tail] != [string length $errInfo]} {
# Very likely cannot happen
return -options $opts $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\"$cinfo\""
set last [string last $tail $errInfo]
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} {
return -code error -errorcode $errCode \
-errorinfo $errInfo $msg
}
set errInfo [string range $errInfo 0 $last-1]
set tail "\n invoked from within\n"
set last [string last $tail $errInfo]
if {$last + [string length $tail] == [string length $errInfo]} {
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {([string index $line 0] eq "#") \
|| ([llength $line] != 2)} {
| > | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
fconfigure $f -encoding utf-8 -eofchar \032
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {([string index $line 0] eq "#") \
|| ([llength $line] != 2)} {
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
| | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
if {[string first $nsrc $ndest] >= 0} {
set srclen [expr {[llength [file split $nsrc]] - 1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
|
| ︙ | ︙ |
Changes to library/install.tcl.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
###
set package [lindex [split $fname -] 0]
set version [lindex [split $fname -] 1]
###
# Read the file, and override assumptions as needed
###
set fin [open $file r]
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]
| > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
###
set package [lindex [split $fname -] 0]
set version [lindex [split $fname -] 1]
###
# Read the file, and override assumptions as needed
###
set fin [open $file r]
fconfigure $fin -encoding utf-8 -eofchar \032
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]
|
| ︙ | ︙ | |||
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 |
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]
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]
set dat [read $fin]
close $fin
set trace 0
#if {[file tail $path] eq "tool"} {
# set trace 1
#}
set thisline {}
| > > | 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 |
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 \032
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 \032
set dat [read $fin]
close $fin
set trace 0
#if {[file tail $path] eq "tool"} {
# set trace 1
#}
set thisline {}
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
}
if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
set thisline {} ; continue
}
if {![regexp "package.*ifneeded" $thisline]} {
# This package index contains arbitrary code
| | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
}
if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
set thisline {} ; continue
}
if {![regexp "package.*ifneeded" $thisline]} {
# This package index contains arbitrary code
# source instead of trying to add it to the main
# package index
if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" }
return {source [file join $dir pkgIndex.tcl]}
}
append buffer $thisline \n
set thisline {}
}
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
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 215 216 217 218 219 220 |
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 {
file attributes $d2 -readonly 1
}
}
proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
#if {$toplevel} {
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
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 20 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.10.0a1 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.tcl}
1 opt 0.4.8 {opt optparse.tcl}
0 cookiejar 0.2.0 {cookiejar cookiejar.tcl}
0 tcl::idna 1.0.1 {cookiejar idna.tcl}
0 platform 1.0.15 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.3 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/msgcat/msgcat.tcl.
1 2 3 4 5 6 | # msgcat.tcl -- # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # | | | | | | 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 |
# msgcat.tcl --
#
# This file defines various procedures which implement a
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
# Copyright © 2010-2018 Harald Oehlmann.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 1998 Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# We use oo::define::self, which is new in Tcl 8.7
package require Tcl 8.7-
# 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
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
| | | | | | > > > > | < < | | 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 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
set result [list {}]
set el {}
foreach e [split $locale _] {
if {$el eq {}} {
set el ${e}
} else {
set el ${el}_${e}
}
if {[string index $el end] != {_}} {
set result [linsert $result 0 $el]
}
}
return $result
}
# msgcat::mcpreferences --
#
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
#
|
| ︙ | ︙ |
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 [file join $dir msgcat.tcl]]
|
Changes to library/opt/optparse.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# optparse.tcl --
#
# (private) Option parsing package
# Primarily used internally by the safe:: code.
#
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.8
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
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"}
| | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
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"}
|
| ︙ | ︙ |
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.8 [list source [file join $dir optparse.tcl]]
|
Changes to library/package.tcl.
1 2 3 4 5 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
namespace eval tcl::Pkg {}
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | } } $c eval [list set ::tcl::dir $dir] $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] | | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
}
}
$c eval [list set ::tcl::dir $dir]
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
# Download needed procedures into the child because we've just deleted
# the unknown procedure. This doesn't handle procedures with default
# arguments.
foreach p {::tcl::Pkg::CompareExtension} {
$c eval [list namespace eval [namespace qualifiers $p] {}]
$c eval [list proc $p [info args $p] [info body $p]]
}
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open [file join $dir pkgIndex.tcl] w]
puts $f $index
close $f
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked as
# part of a "package ifneeded" script. It calls "package provide" to indicate
| > | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open [file join $dir pkgIndex.tcl] w]
fconfigure $f -encoding utf-8 -translation lf
puts $f $index
close $f
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked as
# part of a "package ifneeded" script. It calls "package provide" to indicate
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
| < | > | > > > | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 |
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# Get the pkgIndex.tcl files in subdirectories of auto_path directories.
# - Safe Base interpreters have a restricted "glob" command that
# works in this case.
# - The "catch" was essential when there was no safe glob and every
# call in a safe interp failed; it is retained only for corner
# cases in which the eventual call to glob returns an error.
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
| > | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
# Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
|
| ︙ | ︙ |
Changes to library/parray.tcl.
1 2 3 | # parray: # Print the contents of a global array on stdout. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# parray:
# Print the contents of a global array on stdout.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
|
| ︙ | ︙ |
Changes to library/platform/pkgIndex.tcl.
|
| | | 1 2 3 | package ifneeded platform 1.0.15 [list source [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] |
Changes to library/platform/platform.tcl.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
if {$tcl_platform(wordSize) == 4} {
append cpu _32
}
}
}
switch -glob -- $plat {
| < < < | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
if {$tcl_platform(wordSize) == 4} {
append cpu _32
}
}
}
switch -glob -- $plat {
windows {
if {$tcl_platform(platform) == "unix"} {
set plat cygwin
} else {
set plat win32
}
if {$cpu eq "amd64"} {
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
append cpu 64
}
}
}
osf1 {
set plat tru64
}
}
return "${plat}-${cpu}"
}
# -- platform::identify
#
| > > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
append cpu 64
}
}
}
osf1 {
set plat tru64
}
default {
set plat [lindex [split $plat _-] 0]
}
}
return "${plat}-${cpu}"
}
# -- platform::identify
#
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
solaris {
regsub {^5} $tcl_platform(osVersion) 2 text
append plat $text
return "${plat}-${cpu}"
}
macosx {
set major [lindex [split $tcl_platform(osVersion) .] 0]
| | > > > > | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
solaris {
regsub {^5} $tcl_platform(osVersion) 2 text
append plat $text
return "${plat}-${cpu}"
}
macosx {
set major [lindex [split $tcl_platform(osVersion) .] 0]
if {$major > 19} {
incr major -20
append plat 11.$major
} else {
incr major -4
append plat 10.$major
return "${plat}-${cpu}"
}
return "${plat}-${cpu}"
}
linux {
# Look for the libc*.so and determine its version
# (libc5/6, libc6 further glibc 2.X)
set v unknown
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
macosx-x86_64 {
lappend res macosx-i386-x86_64
}
macosx-ix86 {
lappend res macosx-universal macosx-i386-x86_64
}
macosx*-* {
| | | > > > > > > > > > < > > > > > > > > > > > > > | > | 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 |
macosx-x86_64 {
lappend res macosx-i386-x86_64
}
macosx-ix86 {
lappend res macosx-universal macosx-i386-x86_64
}
macosx*-* {
# 10.5+,11.0+
if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
switch -exact -- $cpu {
ix86 {
lappend alt i386-x86_64
lappend alt universal
}
x86_64 {
if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} {
set alt i386-x86_64
} else {
set alt {}
}
}
arm {
lappend alt x86_64
}
default { set alt {} }
}
if {$v ne ""} {
foreach {major minor} [split $v .] break
set res {}
if {$major eq 11} {
# Add 11.0 to 11.minor to patterns.
for {set j $minor} {$j >= 0} {incr j -1} {
lappend res macosx${major}.${j}-${cpu}
foreach a $alt {
lappend res macosx${major}.${j}-$a
}
}
set major 10
set minor 15
}
# Add 10.5 to 10.minor to patterns.
for {set j $minor} {$j >= 5} {incr j -1} {
if {$cpu ne "arm"} {
lappend res macosx${major}.${j}-${cpu}
}
foreach a $alt {
lappend res macosx${major}.${j}-$a
}
}
# Add unversioned patterns for 10.3/10.4 builds.
lappend res macosx-${cpu}
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
return $res
}
# ### ### ### ######### ######### #########
## Ready
| | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
return $res
}
# ### ### ### ######### ######### #########
## Ready
package provide platform 1.0.15
# ### ### ### ######### ######### #########
## Demo application
if {[info exists argv0] && ($argv0 eq [info script])} {
puts ====================================
parray tcl_platform
|
| ︙ | ︙ |
Name change from library/reg/pkgIndex.tcl to library/registry/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
| < | | < < < < | 1 2 3 4 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded registry 1.3.5 \
[list load [file join $dir tclregistry13.dll]]
|
Changes to library/safe.tcl.
1 2 3 4 | # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. # It implements a virtual path mecanism to hide the real pathnames from the | | | | | | 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 |
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# child. It runs in a parent interpreter and sets up data structure and
# aliases that will be invoked when used from a child interpreter.
#
# See the safe.n man page for details.
#
# Copyright © 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.
#
# The implementation is based on namespaces. These naming conventions are
# followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
package require opt 0.4.8
# Create the safe namespace
namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath setLogCmd
}
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
| > | | | > | | | | | | | 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 |
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
RejectExcessColons $child
InterpCreate $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
proc ::safe::interpInit {args} {
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $child]} {
return -code error "\"$child\" is not an interpreter"
}
RejectExcessColons $child
InterpInit $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
# Check that the given child is "one of us"
proc ::safe::CheckInterp {child} {
namespace upvar ::safe [VarName $child] state
if {![info exists state] || ![::interp exists $child]} {
return -code error \
"\"$child\" is not an interpreter managed by ::safe::"
}
}
# Interface/entry point function and front end for "Configure". This code
# is awfully pedestrian because it would need more coupling and support
# between the way we store the configuration values in safe::interp's and
# the Opt package. Obviously we would like an OptConfigure to avoid
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
| | | | | | | | 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 |
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
# we know that "child" is our given argument because it also
# checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $child
namespace upvar ::safe [VarName $child] state
return [join [list \
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
[list -deleteHook $state(cleanupHook)]]]
}
2 {
# If we have exactly 2 arguments the semantic is a "configure
# get"
lassign $args child arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
set hits [::tcl::OptHits desc $arg]
if {$hits > 1} {
return -code error [::tcl::OptAmbigous $desc $arg]
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $child
namespace upvar ::safe [VarName $child] state
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath $state(access_path)]
}
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
}
}
}
default {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
| | | | | | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
}
}
}
default {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $child
namespace upvar ::safe [VarName $child] state
# Get the current (and not the default) values of whatever has
# not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
set doreset 0
set accessPath $state(access_path)
} else {
set doreset 1
}
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
} then {
set statics $state(staticsok)
} else {
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
| | | | | | | > > > > > > > > > > > > > > > > > > > | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | > > > > | > > | | | > | > | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} else {
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
InterpSetConfig $child $accessPath $statics $nested $deleteHook
# auto_reset the child (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $child {auto_reset}} msg]} {
Log $child "auto_reset failed: $msg"
} else {
Log $child "successful auto_reset" NOTICE
}
# Sync the paths used to search for Tcl modules.
::interp eval $child {tcl::tm::path remove {*}[tcl::tm::list]}
if {[llength $state(tm_path_child)] > 0} {
::interp eval $child [list \
::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
}
# Remove stale "package ifneeded" data for non-loaded packages.
# - Not for loaded packages, because "package forget" erases
# data from "package provide" as well as "package ifneeded".
# - This is OK because the script cannot reload any version of
# the package unless it first does "package forget".
foreach pkg [::interp eval $child {package names}] {
if {[::interp eval $child [list package provide $pkg]] eq ""} {
::interp eval $child [list package forget $pkg]
}
}
}
return
}
}
}
####
#
# Functions that actually implements the exported APIs
#
####
#
# safe::InterpCreate : doing the real job
#
# This procedure creates a safe interpreter and initializes it with the safe
# base aliases.
# NB: child name must be simple alphanumeric string, no spaces, no (), no
# {},... {because the state array is stored as part of the name}
#
# Returns the child name.
#
# Optional Arguments :
# + child name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
# if empty: the parent auto_path will be used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
child
access_path
staticsok
nestedok
deletehook
} {
# Create the child.
# If evaluated in ::safe, the interpreter command for foo is ::foo;
# but for foo::bar is safe::foo::bar. So evaluate in :: instead.
if {$child ne ""} {
namespace eval :: [list ::interp create -safe $child]
} else {
# empty argument: generate child name
set child [::interp create -safe]
}
Log $child "Created" NOTICE
# Initialize it. (returns child name)
InterpInit $child $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
# Sets up child virtual auto_path and corresponding structure within
# the parent. Also sets the tcl_library in the child to be the first
# directory in the path.
# NB: If you change the path after the child has been initialized you
# probably need to call "auto_reset" in the child in order that it gets
# the right auto_index() array values.
proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
global auto_path
# determine and store the access path if empty
if {$access_path eq ""} {
set access_path $auto_path
# Make sure that tcl_library is in auto_path and at the first
# position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where < 0} {
# not found, add it.
set access_path [linsert $access_path 0 [info library]]
Log $child "tcl_library was not in auto_path,\
added it to child's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [linsert \
[lreplace $access_path $where $where] \
0 [info library]]
Log $child "tcl_libray was not in first in auto_path,\
moved it to front of child's access_path" NOTICE
}
# Add 1st level sub dirs (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]
}
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" 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.
# We save the virtual form separately as well, as syncing it with the
# child has to be defered until the necessary commands are present for
# setup.
set norm_access_path {}
set child_access_path {}
set map_access_path {}
set remap_access_path {}
set child_tm_path {}
set i 0
foreach dir $access_path {
set token [PathToken $i]
lappend child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
incr i
}
set morepaths [::tcl::tm::list]
set firstpass 1
while {[llength $morepaths]} {
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
}
set token [PathToken $i]
lappend access_path $dir
lappend child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $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 $token
}
incr i
# [Bug 2854929]
# Recursively find deeper paths which may contain
# modules. Required to handle modules with names like
# 'platform::shell', which translate into
# 'platform/shell-X.tm', i.e arbitrarily deep
# subdirectories.
lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
}
set firstpass 0
}
set state(access_path) $access_path
set state(access_path,map) $map_access_path
set state(access_path,remap) $remap_access_path
set state(access_path,norm) $norm_access_path
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
SyncAccessPath $child
return
}
#
#
# FindInAccessPath:
# Search for a real directory and returns its virtual Id (including the
# "$")
proc ::safe::interpFindInAccessPath {child path} {
CheckInterp $child
namespace upvar ::safe [VarName $child] state
if {![dict exists $state(access_path,remap) $path]} {
return -code error "$path not found in access path"
}
return [dict get $state(access_path,remap) $path]
}
#
# addToAccessPath:
# add (if needed) a real directory to access path and return its
# virtual token (including the "$").
proc ::safe::interpAddToAccessPath {child path} {
# first check if the directory is already in there
# (inlined interpFindInAccessPath).
CheckInterp $child
namespace upvar ::safe [VarName $child] state
if {[dict exists $state(access_path,remap) $path]} {
return [dict get $state(access_path,remap) $path]
}
# new one, add it:
set token [PathToken [llength $state(access_path)]]
lappend state(access_path) $path
lappend state(access_path,child) $token
lappend state(access_path,map) $token $path
lappend state(access_path,remap) $path $token
lappend state(access_path,norm) [file normalize $path]
SyncAccessPath $child
return $token
}
# This procedure applies the initializations to an already existing
# interpreter. It is useful when you want to install the safe base aliases
# into a preexisting safe interpreter.
proc ::safe::InterpInit {
child
access_path
staticsok
nestedok
deletehook
} {
# Configure will generate an access_path when access_path is empty.
InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
# NB we need to add [namespace current], aliases are always absolute
# paths.
# These aliases let the child load files to define new commands
# This alias lets the child use the encoding names, convertfrom,
# convertto, and system, but not "encoding system <name>" to set the
# system encoding.
# Handling Tcl Modules, we need a restricted form of Glob.
# This alias interposes on the 'exit' command and cleanly terminates
# the child.
foreach {command alias} {
source AliasSource
load AliasLoad
exit interpDelete
glob AliasGlob
} {
::interp alias $child $command {} [namespace current]::$alias $child
}
# UGLY POINT! These commands are safe (they're ensembles with unsafe
# subcommands), but is assumed to not be by existing policies so it is
# hidden by default. Hack it...
foreach command {encoding file} {
::interp alias $child $command {} interp invokehidden $child $command
}
# This alias lets the child have access to a subset of the 'file'
# command functionality.
foreach subcommand {dirname extension rootname tail} {
::interp alias $child ::tcl::file::$subcommand {} \
::safe::AliasFileSubcommand $child $subcommand
}
# Subcommand of 'encoding' that has special handling; [encoding system] is
# OK provided it has no other arguments passed to it.
::interp alias $child ::tcl::encoding::system {} \
::safe::AliasEncodingSystem $child
# Subcommands of info
::interp alias $child ::tcl::info::nameofexecutable {} \
::safe::AliasExeName $child
# The allowed child variables already have been set by Tcl_MakeSafe(3)
# Source init.tcl and tm.tcl into the child, to get auto_load and
# other procedures defined:
if {[catch {::interp eval $child {
source [file join $tcl_library init.tcl]
}} msg opt]} {
Log $child "can't source init.tcl ($msg)"
return -options $opt "can't source init.tcl into child $child ($msg)"
}
if {[catch {::interp eval $child {
source [file join $tcl_library tm.tcl]
}} msg opt]} {
Log $child "can't source tm.tcl ($msg)"
return -options $opt "can't source tm.tcl into child $child ($msg)"
}
# Sync the paths used to search for Tcl modules. This can be done only
# now, after tm.tcl was loaded.
namespace upvar ::safe [VarName $child] state
if {[llength $state(tm_path_child)] > 0} {
::interp eval $child [list \
::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
}
return $child
}
# Add (only if needed, avoid duplicates) 1 level of sub directories to an
# existing path list. Also removes non directories from the returned
# list.
proc ::safe::AddSubDirs {pathList} {
set res {}
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
}
}
}
}
return $res
}
| | | > > > | | > | > > > > > > > > > > > | | | | | | | | 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 |
}
}
}
}
return $res
}
# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up
# associated state.
# - The command will also delete non-Safe-Base interpreters.
# - This is regrettable, but to avoid breaking existing code this should be
# amended at the next major revision by uncommenting "CheckInterp".
proc ::safe::interpDelete {child} {
Log $child "About to delete" NOTICE
# CheckInterp $child
namespace upvar ::safe [VarName $child] state
# 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
# existance because we might be called to delete an interp which has
# not been registered with us at all
if {[info exists state(cleanupHook)]} {
set hook $state(cleanupHook)
if {[llength $hook]} {
# remove the hook now, otherwise if the hook calls us somehow,
# we'll loop
unset state(cleanupHook)
try {
{*}$hook $child
} on error err {
Log $child "Delete hook error ($err)"
}
}
}
# Discard the global array of state associated with the child, and
# delete the interpreter.
if {[info exists state]} {
unset state
}
# if we have been called twice, the interp might have been deleted
# already
if {[::interp exists $child]} {
::interp delete $child
Log $child "Deleted" NOTICE
}
return
}
# Set (or get) the logging mecanism
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
if {$Log eq ""} {
# Disable logging completely. Calls to it will be compiled out
# of all users.
proc ::safe::Log {args} {}
} else {
# Activate logging, define proper command.
| | | | | | | | | | | | | | | | | | | 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 |
if {$Log eq ""} {
# Disable logging completely. Calls to it will be compiled out
# of all users.
proc ::safe::Log {args} {}
} else {
# Activate logging, define proper command.
proc ::safe::Log {child msg {type ERROR}} {
variable Log
{*}$Log "$type for child $child : $msg"
return
}
}
}
# ------------------- END OF PUBLIC METHODS ------------
#
# Sets the child auto_path to the parent recorded value. Also sets
# tcl_library to the first token of the virtual path.
#
proc ::safe::SyncAccessPath {child} {
namespace upvar ::safe [VarName $child] state
set child_access_path $state(access_path,child)
::interp eval $child [list set auto_path $child_access_path]
Log $child "auto_path in $child has been set to $child_access_path"\
NOTICE
# This code assumes that info library is the first element in the
# list of auto_path's. See -> InterpSetConfig for the code which
# ensures this condition.
::interp eval $child [list \
set tcl_library [lindex $child_access_path 0]]
}
# Returns the virtual token for directory number N.
proc ::safe::PathToken {n} {
# We need to have a ":" in the token string so [file join] on the
# mac won't turn it into a relative path.
return "\$p(:$n:)" ;# Form tested by case 7.2
}
#
# translate virtual path into real path
#
proc ::safe::TranslatePath {child path} {
namespace upvar ::safe [VarName $child] state
# somehow strip the namespaces 'functionality' out (the danger is that
# we would strip valid macintosh "../" queries... :
if {[string match "*::*" $path] || [string match "*..*" $path]} {
return -code error "invalid characters in path $path"
}
# Use a cached map instead of computed local vars and subst.
return [string map $state(access_path,map) $path]
}
# file name control (limit access to files/resources that should be a
# valid tcl source file)
proc ::safe::CheckFileName {child file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
# for 8.4 as a safe interp has enough internal protection already to
# allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
return -code error "no such file or directory"
}
if {![file readable $file]} {
# don't tell the file path
return -code error "not readable"
}
}
# AliasFileSubcommand handles selected subcommands of [file] in safe
# interpreters that are *almost* safe. In particular, it just acts to
# prevent discovery of what home directories exist.
proc ::safe::AliasFileSubcommand {child subcommand name} {
if {[string match ~* $name]} {
set name ./$name
}
tailcall ::interp invokehidden $child tcl:file:$subcommand $name
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {child args} {
Log $child "GLOB ! $args" NOTICE
set cmd {}
set at 0
array set got {
-directory 0
-nocomplain 0
-join 0
-tails 0
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
}
set dir {}
set virtualdir {}
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
| | > > > > < < < < < < < | | | | | > > > | | > > > > > > > | > | > | > | < > > > > | | | | | > > > > > > > > > > > > > > > > > > | | | > > > > > > > | > > | | | | | | | | | | | | | | > > > | | | | | < < | < | | | | | | | | | | | | | | | > > > > > > > | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | 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 |
}
set dir {}
set virtualdir {}
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
-nocomplain - -- - -tails {
lappend cmd $opt
set got($opt) 1
incr at
}
-join {
set got($opt) 1
incr at
}
-types - -type {
lappend cmd -types [lindex $args [incr at]]
incr at
}
-directory {
if {$got($opt)} {
return -code error \
{"-directory" cannot be used with "-path"}
}
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
}
-* {
Log $child "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
}
default {
break
}
}
if {$got(--)} break
}
# Get the real path from the virtual one and check that the path is in the
# access path of that child. Done after basic argument processing so that
# we know if -nocomplain is set.
if {$got(-directory)} {
try {
set dir [TranslatePath $child $virtualdir]
DirInAccessPath $child $dir
} on error msg {
Log $child $msg
if {$got(-nocomplain)} return
return -code error "permission denied"
}
if {$got(--)} {
set cmd [linsert $cmd end-1 -directory $dir]
} else {
lappend cmd -directory $dir
}
} else {
# The code after this "if ... else" block would conspire to return with
# no results in this case, if it were allowed to proceed. Instead,
# return now and reduce the number of cases to be considered later.
Log $child {option -directory must be supplied}
if {$got(-nocomplain)} return
return -code error "permission denied"
}
# Apply the -join semantics ourselves.
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
# Process the pattern arguments. If we've done a join there is only one
# pattern argument.
set firstPattern [llength $cmd]
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
# The *.tm search comes here.
}
# "Special" treatment for (joined) argument {*/pkgIndex.tcl}.
# Do the expansion of "*" here, and filter out any directories that are
# not in the access path. The outcome is to lappend to cmd a path of
# the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir,
# after removing any subdir that are not in the access path.
if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} {
set mapped 0
foreach d [glob -directory [TranslatePath $child $virtualdir] \
-types d -tails *] {
catch {
DirInAccessPath $child \
[TranslatePath $child [file join $virtualdir $d]]
lappend cmd [file join $d $thefile]
set mapped 1
}
}
if {$mapped} continue
# Don't [continue] if */pkgIndex.tcl has no matches in the access
# path. The pattern will now receive the same treatment as a
# "non-special" pattern (and will fail because it includes a "*" in
# the directory name).
}
# Any directory pattern that is not an exact (i.e. non-glob) match to a
# directory in the access path will be rejected here.
# - Rejections include any directory pattern that has glob matching
# patterns "*", "?", backslashes, braces or square brackets, (UNLESS
# it corresponds to a genuine directory name AND that directory is in
# the access path).
# - The only "special matching characters" that remain in patterns for
# processing by glob are in the filename tail.
# - [file join $anything ~${foo}] is ~${foo}, which is not an exact
# match to any directory in the access path. Hence directory patterns
# that begin with "~" are rejected here. Tests safe-16.[5-8] check
# that "file join" remains as required and does not expand ~${foo}.
# - Bug [3529949] relates to unwanted expansion of ~${foo} and this is
# how the present code avoids the bug. All tests safe-16.* relate.
try {
DirInAccessPath $child [TranslatePath $child \
[file join $virtualdir $thedir]]
} on error msg {
Log $child $msg
if {$got(-nocomplain)} continue
return -code error "permission denied"
}
lappend cmd $opt
}
Log $child "GLOB = $cmd" NOTICE
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
try {
# >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<<
# - Pattern arguments added to cmd have NOT been translated from tokens.
# Only the virtualdir is translated (to dir).
# - In the pkgIndex.tcl case, there is no "*" in the pattern arguments,
# which are a list of names each with tail pkgIndex.tcl. The purpose
# of the call to glob is to remove the names for which the file does
# not exist.
set entries [::interp invokehidden $child glob {*}$cmd]
} on error msg {
# This is the only place that a call with -nocomplain and no invalid
# "dash-options" can return an error.
Log $child $msg
return -code error "script error"
}
Log $child "GLOB < $entries" NOTICE
# Translate path back to what the child should see.
set res {}
set l [string length $dir]
foreach p $entries {
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
}
lappend res $p
}
Log $child "GLOB > $res" NOTICE
return $res
}
# AliasSource is the target of the "source" alias in safe interpreters.
proc ::safe::AliasSource {child args} {
set argc [llength $args]
# Extended for handling of Tcl Modules to allow not only "source
# filename", but "source -encoding E filename" as well.
if {[lindex $args 0] eq "-encoding"} {
incr argc -2
set encoding [lindex $args 1]
set at 2
if {$encoding eq "identity"} {
Log $child "attempt to use the identity encoding"
return -code error "permission denied"
}
} else {
set at 0
set encoding utf-8
}
if {$argc != 1} {
set msg "wrong # args: should be \"source ?-encoding E? fileName\""
Log $child "$msg ($args)"
return -code error $msg
}
set file [lindex $args $at]
# get the real path from the virtual one.
if {[catch {
set realfile [TranslatePath $child $file]
} msg]} {
Log $child $msg
return -code error "permission denied"
}
# check that the path is in the access path of that child
if {[catch {
FileInAccessPath $child $realfile
} msg]} {
Log $child $msg
return -code error "permission denied"
}
# Check that the filename exists and is readable. If it is not, deliver
# this -errorcode so that caller in tclPkgUnknown does not write a message
# to tclLog. Has no effect on other callers of ::source, which are in
# "package ifneeded" scripts.
if {[catch {
CheckFileName $child $realfile
} msg]} {
Log $child "$realfile:$msg"
return -code error -errorcode {POSIX EACCES} $msg
}
# Passed all the tests, lets source it. Note that we do this all manually
# because we want to control [info script] in the child so information
# doesn't leak so much. [Bug 2913625]
set old [::interp eval $child {info script}]
set replacementMsg "script error"
set code [catch {
set f [open $realfile]
fconfigure $f -encoding $encoding -eofchar \032
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} {
Log $child $msg
return -code error $replacementMsg
}
return -code $code -options $opt $msg
}
# AliasLoad is the target of the "load" alias in safe interpreters.
proc ::safe::AliasLoad {child file args} {
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
Log $child "$msg ($argc) {$file $args}"
return -code error $msg
}
# package name (can be empty if file is not).
set package [lindex $args 0]
namespace upvar ::safe [VarName $child] state
# Determine where to load. load use a relative interp path and {}
# means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {$target ne ""} {
# we will try to load into a sub sub interp; check that we want to
# authorize that.
if {!$state(nestedok)} {
Log $child "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {$file eq ""} {
# static package loading
if {$package eq ""} {
set msg "load error: empty filename and no package name"
Log $child $msg
return -code error $msg
}
if {!$state(staticsok)} {
Log $child "static packages loading disabled\
(trying to load $package to $target)"
return -code error "permission denied (static package)"
}
} else {
# file loading
# get the real path from the virtual one.
try {
set file [TranslatePath $child $file]
} on error msg {
Log $child $msg
return -code error "permission denied"
}
# check the translated path
try {
FileInAccessPath $child $file
} on error msg {
Log $child $msg
return -code error "permission denied (path)"
}
}
try {
return [::interp invokehidden $child load $file $package $target]
} on error msg {
# Some packages return no error message.
set msg0 "load of binary library for package $package failed"
if {$msg eq {}} {
set msg $msg0
} else {
set msg "$msg0: $msg"
}
Log $child $msg
return -code error $msg
}
}
# FileInAccessPath raises an error if the file is not found in the list of
# directories contained in the (parent side recorded) child's access path.
# the security here relies on "file dirname" answering the proper
# result... needs checking ?
proc ::safe::FileInAccessPath {child file} {
namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isdirectory $file]} {
return -code error "\"$file\": is a directory"
}
set parent [file dirname $file]
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_parent [file normalize $parent]
namespace upvar ::safe [VarName $child] state
if {$norm_parent ni $state(access_path,norm)} {
return -code error "\"$file\": not in access_path"
}
}
proc ::safe::DirInAccessPath {child dir} {
namespace upvar ::safe [VarName $child] state
set access_path $state(access_path)
if {[file isfile $dir]} {
return -code error "\"$dir\": is a file"
}
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_dir [file normalize $dir]
namespace upvar ::safe [VarName $child] state
if {$norm_dir ni $state(access_path,norm)} {
return -code error "\"$dir\": not in access_path"
}
}
# This procedure is used to report an attempt to use an unsafe member of an
# ensemble command.
proc ::safe::BadSubcommand {child command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $child $msg
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncodingSystem is the target of the "encoding system" alias in safe
# interpreters.
proc ::safe::AliasEncodingSystem {child args} {
try {
# Must not pass extra arguments; safe interpreters may not set the
# system encoding but they may read it.
if {[llength $args]} {
return -code error -errorcode {TCL WRONGARGS} \
"wrong # args: should be \"encoding system\""
}
} on error {msg options} {
Log $child $msg
return -options $options $msg
}
tailcall ::interp invokehidden $child tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
proc ::safe::AliasExeName {child} {
return ""
}
# ------------------------------------------------------------------------------
# Using Interpreter Names with Namespace Qualifiers
# ------------------------------------------------------------------------------
# (1) We wish to preserve compatibility with existing code, in which Safe Base
# interpreter names have no namespace qualifiers.
# (2) safe::interpCreate and the rest of the Safe Base previously could not
# accept namespace qualifiers in an interpreter name.
# (3) The interp command will accept namespace qualifiers in an interpreter
# name, but accepts distinct interpreters that will have the same command
# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974).
# (4) To satisfy these constraints, Safe Base interpreter names will be fully
# qualified namespace names with no excess colons and with the leading "::"
# omitted.
# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}.
# Reject such names.
# (6) We could:
# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in
# interpCreate, interpInit;
# (b) OR accept such names and then translate to a compliant name in every
# command.
# The problem with (b) is that the user will expect to use the name with the
# interp command and will find that it is not recognised.
# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name
# "::foo" works with all the Safe Base commands, but "interp eval ::foo"
# fails.
# So we choose (a).
# (7) The command
# namespace upvar ::safe S$child state
# 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]
}
proc ::safe::Setup {} {
####
#
# Setup the arguments parsing
#
####
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the child"}
{-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"}
}]
# create case (child is optional)
::tcl::OptKeyRegister {
{?child? -name {} "name of the child (optional)"}
} ::safe::interpCreate
# adding the flags sub programs to the command program (relying on Opt's
# internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (child is needed)
::tcl::OptKeyRegister {
{child -name {} "name of the child"}
} ::safe::interpIC
# adding the flags sub programs to the command program (relying on Opt's
# internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
|
| ︙ | ︙ | |||
1102 1103 1104 1105 1106 1107 1108 |
namespace eval ::safe {
# internal variables
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
| | | | | | | 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 |
namespace eval ::safe {
# internal variables
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
# The package maintains a state array per child interp under its
# control. The name of this array is S<interp-name>. This array is
# brought into scope where needed, using 'namespace upvar'. The S
# prefix is used to avoid that a child interp called "Log" smashes
# the "Log" variable.
#
# The array's elements are:
#
# access_path : List of paths accessible to the child.
# access_path,norm : Ditto, in normalized form.
# access_path,child : Ditto, as the path tokens as seen by the child.
# access_path,map : dict ( token -> path )
# access_path,remap : dict ( path -> token )
# tm_path_child : List of TM root directories, as tokens seen by the child.
# staticsok : Value of option -statics
# nestedok : Value of option -nested
# cleanupHook : Value of option -deleteHook
}
::safe::Setup
|
Changes to library/tclIndex.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | 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]] | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | 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(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]] |
| ︙ | ︙ |
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.3 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It # defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, # etc. used by Tcl tests. See the tcltest man page for more # details. # # This design was based on the Tcl testing approach designed and # initially implemented by Mary Ann May-Pumphrey of Sun # Microsystems. # # Copyright (c) 1994-1997 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 |
# tcltest.tcl --
#
# This file contains support code for the Tcl test suite. It
# defines the tcltest namespace and finds and defines the output
# directory, constraints available, output and error channels,
# etc. used by Tcl tests. See the tcltest man page for more
# details.
#
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2000 Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
package require Tcl 8.5- ;# -verbose line uses [info frame]
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.3
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory \
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] 8.7-]} {
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]
namespace export match ;# [configure -match]
namespace export matchFiles ;# [configure -file]
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
switch -exact -- $filename {
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
set ChannelsWeOpened($outputChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
| > > > | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
switch -exact -- $filename {
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $outputChannel -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
switch -exact -- $filename {
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
set ChannelsWeOpened($errorChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
| > > > | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
switch -exact -- $filename {
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $errorChannel -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
| | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}]
}
# Default verbosity is to show bodies of failed tests
Option -verbose {body error} {
Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
| > > > | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $tmp -encoding utf-8
}
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
|
| ︙ | ︙ | |||
807 808 809 810 811 812 813 |
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
| | | | | | | | 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
proc loadIntoChildInterpreter {child args} {
variable Version
interp eval $child [package ifneeded tcltest $Version]
interp eval $child "tcltest::configure {*}{$args}"
interp alias $child ::tcltest::ReportToParent \
{} ::tcltest::ReportedFromChild
}
proc ReportedFromChild {total passed skipped failed because newfiles} {
variable numTests
variable skippedBecause
variable createdNewFiles
incr numTests(Total) $total
incr numTests(Passed) $passed
incr numTests(Skipped) $skipped
incr numTests(Failed) $failed
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
| | | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {fconfigure $f -blocking off}]}]
catch {close $f}
set code
}
# Set asyncPipeClose constraint: 1 means this platform supports
# async flush and async close on a pipe.
#
|
| ︙ | ︙ | |||
1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 |
}
set code
}
ConstraintInitializer stdio {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
set code
| > > > | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
}
set code
}
ConstraintInitializer stdio {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
set code
|
| ︙ | ︙ | |||
2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 |
[dict get $testFrame type] eq "source"} {
set testFile [dict get $testFrame file]
set testLine [dict get $testFrame line]
} else {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
}
}
if {[info exists testLine]} {
| > > > | 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 |
[dict get $testFrame type] eq "source"} {
set testFile [dict get $testFrame file]
set testLine [dict get $testFrame line]
} else {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $testFd -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
}
}
if {[info exists testLine]} {
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
| | | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
if {[llength [info commands [namespace current]::ReportToParent]]} {
ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
$numTests(Failed) [array get skippedBecause] \
[array get createdNewFiles]
set testSingleFile false
}
# Call the cleanup hook
cleanupTestsHook
|
| ︙ | ︙ | |||
2794 2795 2796 2797 2798 2799 2800 |
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
variable DefaultValue
| < | 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 |
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
variable DefaultValue
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
|
| ︙ | ︙ | |||
2850 2851 2852 2853 2854 2855 2856 |
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
| > | | > > > > > > > > > > > > | | 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 |
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
if {[catch {
incr numTestFiles
uplevel 1 [list ::source $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} {
set failFilesSet 1
}
} else {
# Pass along our configuration to the child processes.
# EXCEPT for the -outfile, because the parent process
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
if {$opt eq "-outfile"} {continue}
set value [Configure $opt]
# Don't bother passing default configuration options
if {$value eq $DefaultValue($opt)} {
continue
}
lappend childargv $opt $value
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $pipeFd -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
{Passed\t([0-9]+)\t}
{Skipped\t([0-9]+)\t}
{Failed\t([0-9]+)}
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
set failFilesSet 1
}
} elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
} ""] $line match skipped constraint]} {
if {[string match \t* $match]} {
|
| ︙ | ︙ | |||
2931 2932 2933 2934 2935 2936 2937 |
uplevel 1 [list ::source [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
| | | 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 |
uplevel 1 [list ::source [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]}]
}
#####################################################################
# Test utility procs - not used in tcltest, but may be useful for
# testing.
|
| ︙ | ︙ | |||
3066 3067 3068 3069 3070 3071 3072 |
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
| | > > > | 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 |
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $fd -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
| < | > > | 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
if {$idx < 0} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
} else {
set filesMade [lreplace $filesMade $idx $idx]
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
if {[catch {file delete -- $fullName} msg ]} {
|
| ︙ | ︙ | |||
3179 3180 3181 3182 3183 3184 3185 |
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
| | | 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx < 0} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
}
}
if {![file isdirectory $fullName]} {
DebugDo 1 {
|
| ︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 |
proc tcltest::viewFile {name {directory ""}} {
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
set data [read -nonewline $f]
close $f
return $data
}
# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
# 1. Create denormalized or improperly formed strings to pass to C
# procedures that are supposed to accept strings with embedded NULL
# bytes.
# 2. Confirm that a string result has a certain pattern of bytes, for
| > > > | | > > > > | | > | 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 |
proc tcltest::viewFile {name {directory ""}} {
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
}
set data [read -nonewline $f]
close $f
return $data
}
# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
# 1. Create denormalized or improperly formed strings to pass to C
# procedures that are supposed to accept strings with embedded NULL
# bytes.
# 2. Confirm that a string result has a certain pattern of bytes, for
# instance to confirm that "\xE0\0" in a Tcl script is stored
# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.
#
# This function doesn't work any more in Tcl 8.7, since the 'identity'
# is gone (TIP #345)
#
# Arguments:
# string being converted
#
# Results:
# result fom encoding
#
# Side effects:
# None
if {![package vsatisfies [package provide Tcl] 8.7-]} {
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
}
# tcltest::OpenFiles --
#
# used in io tests, uses testchannel
#
# Arguments:
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
}
set currentsearchpath [file join $path $pkgroot]
if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
| < | < | > > | > | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
}
set currentsearchpath [file join $path $pkgroot]
if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
# Get the module files out of the subdirectories.
# - Safe Base interpreters have a restricted "glob" command that
# works in this case.
# - The "catch" was essential when there was no safe glob and every
# call in a safe interp failed; it is retained only for corner
# cases in which the eventual call to glob returns an error.
catch {
# We always look for _all_ possible modules in the current
# path, to get the max result out of the glob.
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not
# acceptable to "package vcompare".
continue
}
| | > > > > | | 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 |
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not
# acceptable to "package vcompare".
continue
}
if {([package ifneeded $pkgname $pkgversion] ne {})
&& (![interp issafe])
} {
# There's already a provide script registered for
# this version of this package. Since all units of
# code claiming to be the same version of the same
# package ought to be identical, just stick with
# the one we already have.
# This does not apply to Safe Base interpreters because
# the token-to-directory mapping may have changed.
continue
}
# We have found a candidate, generate a "provide script"
# for it, and remember it. Note that we are using ::list
# to do this; locally [list] means something else without
# the namespace specifier.
# NOTE. When making changes to the format of the provide
# command generated below CHECK that the 'LOCATE'
# procedure in core file 'platform/shell.tcl' still
# understands it, or, if not, update its implementation
# appropriately.
#
# Right now LOCATE's implementation assumes that the path
# of the package file is the last element in the list.
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source $file]"
# We abort in this unknown handler only if we got a
# satisfying candidate for the requested package.
# Otherwise we still have to fallback to the regular
# package search to complete the processing.
if {($pkgname eq $name)
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Accra.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Accra) {
{-9223372036854775808 -52 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Accra) {
{-9223372036854775808 -52 0 LMT}
{-1709337548 0 0 GMT}
{-1581206400 1200 1 +0020}
{-1577917200 0 0 GMT}
{-1556834400 1200 1 +0020}
{-1546294800 0 0 GMT}
{-1525298400 1200 1 +0020}
{-1514758800 0 0 GMT}
{-1493762400 1200 1 +0020}
{-1483222800 0 0 GMT}
{-1462226400 1200 1 +0020}
{-1451686800 0 0 GMT}
{-1430604000 1200 1 +0020}
{-1420064400 0 0 GMT}
{-1399068000 1200 1 +0020}
{-1388528400 0 0 GMT}
{-1367532000 1200 1 +0020}
{-1356992400 0 0 GMT}
{-1335996000 1200 1 +0020}
{-1325456400 0 0 GMT}
{-1304373600 1200 1 +0020}
{-1293834000 0 0 GMT}
{-1272837600 1200 1 +0020}
{-1262298000 0 0 GMT}
{-1241301600 1200 1 +0020}
{-1230762000 0 0 GMT}
{-1209765600 1200 1 +0020}
{-1199226000 0 0 GMT}
{-1178143200 1200 1 +0020}
{-1167603600 0 0 GMT}
{-1146607200 1200 1 +0020}
{-1136067600 0 0 GMT}
{-1115071200 1200 1 +0020}
{-1104531600 0 0 GMT}
{-1083535200 1200 1 +0020}
{-1072995600 0 0 GMT}
{-1051912800 1200 1 +0020}
{-1041373200 0 0 GMT}
{-1020376800 1200 1 +0020}
{-1009837200 0 0 GMT}
{-988840800 1200 1 +0020}
{-978301200 0 0 GMT}
{-957304800 1200 1 +0020}
{-946765200 0 0 GMT}
{-936309600 1200 1 +0020}
{-915142800 0 0 GMT}
{-904773600 1200 1 +0020}
{-883606800 0 0 GMT}
{-880329600 1800 0 +0030}
{-756952200 0 0 GMT}
{-610149600 1800 1 +0030}
{-599610600 0 0 GMT}
{-578613600 1800 1 +0030}
{-568074600 0 0 GMT}
{-546991200 1800 1 +0030}
{-536452200 0 0 GMT}
{-515455200 1800 1 +0030}
{-504916200 0 0 GMT}
{-483919200 1800 1 +0030}
{-473380200 0 0 GMT}
{-452383200 1800 1 +0030}
{-441844200 0 0 GMT}
}
|
Changes to library/tzdata/Africa/Algiers.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Algiers) {
{-9223372036854775808 732 0 LMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Algiers) {
{-9223372036854775808 732 0 LMT}
{-2486592732 561 0 PMT}
{-1855958961 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
{-1665363600 3600 1 WEST}
{-1648342800 0 0 WET}
{-1635123600 3600 1 WEST}
{-1616893200 0 0 WET}
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Casablanca.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682820000 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927764000 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
{2172708000 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
{2233792800 3600 0 +01}
{2261008800 0 1 +01}
{2264032800 3600 0 +01}
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
{2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
{2417652000 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
{2478736800 3600 0 +01}
{2505952800 0 1 +01}
{2508976800 3600 0 +01}
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
{2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
{2662596000 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
{2723680800 3600 0 +01}
{2750896800 0 1 +01}
{2753920800 3600 0 +01}
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
{2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
{2907540000 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
{2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
{3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
{3152484000 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
{3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
{3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
{3397428000 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
{3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
{3550442400 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3642372000 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/Africa/El_Aaiun.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682820000 3600 0 +01}
{1710036000 0 1 +01}
{1713060000 3600 0 +01}
{1740276000 0 1 +01}
{1743904800 3600 0 +01}
{1771120800 0 1 +01}
{1774144800 3600 0 +01}
{1801965600 0 1 +01}
{1804989600 3600 0 +01}
{1832205600 0 1 +01}
{1835834400 3600 0 +01}
{1863050400 0 1 +01}
{1866074400 3600 0 +01}
{1893290400 0 1 +01}
{1896919200 3600 0 +01}
{1924135200 0 1 +01}
{1927764000 3600 0 +01}
{1954980000 0 1 +01}
{1958004000 3600 0 +01}
{1985220000 0 1 +01}
{1988848800 3600 0 +01}
{2016064800 0 1 +01}
{2019088800 3600 0 +01}
{2046304800 0 1 +01}
{2049933600 3600 0 +01}
{2077149600 0 1 +01}
{2080778400 3600 0 +01}
{2107994400 0 1 +01}
{2111018400 3600 0 +01}
{2138234400 0 1 +01}
{2141863200 3600 0 +01}
{2169079200 0 1 +01}
{2172708000 3600 0 +01}
{2199924000 0 1 +01}
{2202948000 3600 0 +01}
{2230164000 0 1 +01}
{2233792800 3600 0 +01}
{2261008800 0 1 +01}
{2264032800 3600 0 +01}
{2291248800 0 1 +01}
{2294877600 3600 0 +01}
{2322093600 0 1 +01}
{2325722400 3600 0 +01}
{2352938400 0 1 +01}
{2355962400 3600 0 +01}
{2383178400 0 1 +01}
{2386807200 3600 0 +01}
{2414023200 0 1 +01}
{2417652000 3600 0 +01}
{2444868000 0 1 +01}
{2447892000 3600 0 +01}
{2475108000 0 1 +01}
{2478736800 3600 0 +01}
{2505952800 0 1 +01}
{2508976800 3600 0 +01}
{2536192800 0 1 +01}
{2539821600 3600 0 +01}
{2567037600 0 1 +01}
{2570666400 3600 0 +01}
{2597882400 0 1 +01}
{2600906400 3600 0 +01}
{2628122400 0 1 +01}
{2631751200 3600 0 +01}
{2658967200 0 1 +01}
{2662596000 3600 0 +01}
{2689812000 0 1 +01}
{2692836000 3600 0 +01}
{2720052000 0 1 +01}
{2723680800 3600 0 +01}
{2750896800 0 1 +01}
{2753920800 3600 0 +01}
{2781136800 0 1 +01}
{2784765600 3600 0 +01}
{2811981600 0 1 +01}
{2815610400 3600 0 +01}
{2842826400 0 1 +01}
{2845850400 3600 0 +01}
{2873066400 0 1 +01}
{2876695200 3600 0 +01}
{2903911200 0 1 +01}
{2907540000 3600 0 +01}
{2934756000 0 1 +01}
{2937780000 3600 0 +01}
{2964996000 0 1 +01}
{2968624800 3600 0 +01}
{2995840800 0 1 +01}
{2998864800 3600 0 +01}
{3026080800 0 1 +01}
{3029709600 3600 0 +01}
{3056925600 0 1 +01}
{3060554400 3600 0 +01}
{3087770400 0 1 +01}
{3090794400 3600 0 +01}
{3118010400 0 1 +01}
{3121639200 3600 0 +01}
{3148855200 0 1 +01}
{3152484000 3600 0 +01}
{3179700000 0 1 +01}
{3182724000 3600 0 +01}
{3209940000 0 1 +01}
{3213568800 3600 0 +01}
{3240784800 0 1 +01}
{3243808800 3600 0 +01}
{3271024800 0 1 +01}
{3274653600 3600 0 +01}
{3301869600 0 1 +01}
{3305498400 3600 0 +01}
{3332714400 0 1 +01}
{3335738400 3600 0 +01}
{3362954400 0 1 +01}
{3366583200 3600 0 +01}
{3393799200 0 1 +01}
{3397428000 3600 0 +01}
{3424644000 0 1 +01}
{3427668000 3600 0 +01}
{3454884000 0 1 +01}
{3458512800 3600 0 +01}
{3485728800 0 1 +01}
{3488752800 3600 0 +01}
{3515968800 0 1 +01}
{3519597600 3600 0 +01}
{3546813600 0 1 +01}
{3550442400 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3642372000 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/Africa/Lagos.
1 2 3 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Lagos) {
| | > > > | | 1 2 3 4 5 6 7 8 9 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Lagos) {
{-9223372036854775808 815 0 LMT}
{-2035584815 0 0 GMT}
{-1940889600 815 0 LMT}
{-1767226415 1800 0 +0030}
{-1588465800 3600 0 WAT}
}
|
Changes to library/tzdata/Africa/Nairobi.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Nairobi) {
{-9223372036854775808 8836 0 LMT}
| > | | | | | 1 2 3 4 5 6 7 8 9 10 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Africa/Nairobi) {
{-9223372036854775808 8836 0 LMT}
{-1946168836 9000 0 +0230}
{-1309746600 10800 0 EAT}
{-1261969200 9000 0 +0230}
{-1041388200 9900 0 +0245}
{-865305900 10800 0 EAT}
}
|
Changes to library/tzdata/America/Belize.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
{-974658600 -21600 0 CST}
{-954093600 -19800 1 -0530}
{-943209000 -21600 0 CST}
{-922644000 -19800 1 -0530}
{-911759400 -21600 0 CST}
{-891194400 -19800 1 -0530}
{-879705000 -21600 0 CST}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > | 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 |
{-974658600 -21600 0 CST}
{-954093600 -19800 1 -0530}
{-943209000 -21600 0 CST}
{-922644000 -19800 1 -0530}
{-911759400 -21600 0 CST}
{-891194400 -19800 1 -0530}
{-879705000 -21600 0 CST}
{-868212000 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-758746800 -21600 0 CST}
{-701892000 -19800 1 -0530}
{-690402600 -21600 0 CST}
{-670442400 -19800 1 -0530}
{-658953000 -21600 0 CST}
{-638992800 -19800 1 -0530}
{-627503400 -21600 0 CST}
{-606938400 -19800 1 -0530}
{-596053800 -21600 0 CST}
{-575488800 -19800 1 -0530}
{-564604200 -21600 0 CST}
{-544039200 -19800 1 -0530}
{-532549800 -21600 0 CST}
{-512589600 -19800 1 -0530}
{-501100200 -21600 0 CST}
{-481140000 -19800 1 -0530}
{-469650600 -21600 0 CST}
{-449690400 -19800 1 -0530}
{-438201000 -21600 0 CST}
{-417636000 -19800 1 -0530}
{-406751400 -21600 0 CST}
{-386186400 -19800 1 -0530}
{-375301800 -21600 0 CST}
{-354736800 -19800 1 -0530}
{-343247400 -21600 0 CST}
{-323287200 -19800 1 -0530}
{-311797800 -21600 0 CST}
{-291837600 -19800 1 -0530}
{-280348200 -21600 0 CST}
{-259783200 -19800 1 -0530}
{-248898600 -21600 0 CST}
{-228333600 -19800 1 -0530}
{-217449000 -21600 0 CST}
{-196884000 -19800 1 -0530}
{-185999400 -21600 0 CST}
{-165434400 -19800 1 -0530}
{-153945000 -21600 0 CST}
{-133984800 -19800 1 -0530}
{-122495400 -21600 0 CST}
{-102535200 -19800 1 -0530}
{-91045800 -21600 0 CST}
{-70480800 -19800 1 -0530}
{-59596200 -21600 0 CST}
{123919200 -18000 1 CDT}
{129618000 -21600 0 CST}
{409039200 -18000 1 CDT}
{413874000 -21600 0 CST}
}
|
Changes to library/tzdata/America/Dawson.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
| < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 90 91 92 93 94 95 96 97 98 |
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
{1604217600 -25200 0 MST}
}
|
Changes to library/tzdata/America/Godthab.
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/Nuuk)]} {
LoadTimeZoneFile America/Nuuk
}
set TZData(:America/Godthab) $TZData(:America/Nuuk)
|
Changes to library/tzdata/America/Grand_Turk.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
{1320559200 -18000 0 EST}
{1331449200 -14400 1 EDT}
{1352008800 -18000 0 EST}
{1362898800 -14400 1 EDT}
{1383458400 -18000 0 EST}
{1394348400 -14400 1 EDT}
{1414908000 -18000 0 EST}
| | < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
{1320559200 -18000 0 EST}
{1331449200 -14400 1 EDT}
{1352008800 -18000 0 EST}
{1362898800 -14400 1 EDT}
{1383458400 -18000 0 EST}
{1394348400 -14400 1 EDT}
{1414908000 -18000 0 EST}
{1425798000 -14400 0 AST}
{1520751600 -14400 0 EDT}
{1541311200 -18000 0 EST}
{1552201200 -14400 1 EDT}
{1572760800 -18000 0 EST}
{1583650800 -14400 1 EDT}
{1604210400 -18000 0 EST}
{1615705200 -14400 1 EDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Nassau.
1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Nassau) {
{-9223372036854775808 -18570 0 LMT}
{-1825095030 -18000 0 EST}
{-179341200 -14400 1 EDT}
{-163620000 -18000 0 EST}
{-147891600 -14400 1 EDT}
{-131565600 -18000 0 EST}
{-116442000 -14400 1 EDT}
{-100116000 -18000 0 EST}
{-84387600 -14400 1 EDT}
| > > > > > | 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/Nassau) {
{-9223372036854775808 -18570 0 LMT}
{-1825095030 -18000 0 EST}
{-873140400 -14400 1 EWT}
{-788904000 -18000 0 EST}
{-786222000 -14400 1 EWT}
{-769395600 -14400 1 EPT}
{-763848000 -18000 0 EST}
{-179341200 -14400 1 EDT}
{-163620000 -18000 0 EST}
{-147891600 -14400 1 EDT}
{-131565600 -18000 0 EST}
{-116442000 -14400 1 EDT}
{-100116000 -18000 0 EST}
{-84387600 -14400 1 EDT}
|
| ︙ | ︙ |
Added library/tzdata/America/Nuuk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 -03}
{323845200 -7200 0 -02}
{338950800 -10800 0 -03}
{354675600 -7200 1 -02}
{370400400 -10800 0 -03}
{386125200 -7200 1 -02}
{401850000 -10800 0 -03}
{417574800 -7200 1 -02}
{433299600 -10800 0 -03}
{449024400 -7200 1 -02}
{465354000 -10800 0 -03}
{481078800 -7200 1 -02}
{496803600 -10800 0 -03}
{512528400 -7200 1 -02}
{528253200 -10800 0 -03}
{543978000 -7200 1 -02}
{559702800 -10800 0 -03}
{575427600 -7200 1 -02}
{591152400 -10800 0 -03}
{606877200 -7200 1 -02}
{622602000 -10800 0 -03}
{638326800 -7200 1 -02}
{654656400 -10800 0 -03}
{670381200 -7200 1 -02}
{686106000 -10800 0 -03}
{701830800 -7200 1 -02}
{717555600 -10800 0 -03}
{733280400 -7200 1 -02}
{749005200 -10800 0 -03}
{764730000 -7200 1 -02}
{780454800 -10800 0 -03}
{796179600 -7200 1 -02}
{811904400 -10800 0 -03}
{828234000 -7200 1 -02}
{846378000 -10800 0 -03}
{859683600 -7200 1 -02}
{877827600 -10800 0 -03}
{891133200 -7200 1 -02}
{909277200 -10800 0 -03}
{922582800 -7200 1 -02}
{941331600 -10800 0 -03}
{954032400 -7200 1 -02}
{972781200 -10800 0 -03}
{985482000 -7200 1 -02}
{1004230800 -10800 0 -03}
{1017536400 -7200 1 -02}
{1035680400 -10800 0 -03}
{1048986000 -7200 1 -02}
{1067130000 -10800 0 -03}
{1080435600 -7200 1 -02}
{1099184400 -10800 0 -03}
{1111885200 -7200 1 -02}
{1130634000 -10800 0 -03}
{1143334800 -7200 1 -02}
{1162083600 -10800 0 -03}
{1174784400 -7200 1 -02}
{1193533200 -10800 0 -03}
{1206838800 -7200 1 -02}
{1224982800 -10800 0 -03}
{1238288400 -7200 1 -02}
{1256432400 -10800 0 -03}
{1269738000 -7200 1 -02}
{1288486800 -10800 0 -03}
{1301187600 -7200 1 -02}
{1319936400 -10800 0 -03}
{1332637200 -7200 1 -02}
{1351386000 -10800 0 -03}
{1364691600 -7200 1 -02}
{1382835600 -10800 0 -03}
{1396141200 -7200 1 -02}
{1414285200 -10800 0 -03}
{1427590800 -7200 1 -02}
{1445734800 -10800 0 -03}
{1459040400 -7200 1 -02}
{1477789200 -10800 0 -03}
{1490490000 -7200 1 -02}
{1509238800 -10800 0 -03}
{1521939600 -7200 1 -02}
{1540688400 -10800 0 -03}
{1553994000 -7200 1 -02}
{1572138000 -10800 0 -03}
{1585443600 -7200 1 -02}
{1603587600 -10800 0 -03}
{1616893200 -7200 1 -02}
{1635642000 -10800 0 -03}
{1648342800 -7200 1 -02}
{1667091600 -10800 0 -03}
{1679792400 -7200 1 -02}
{1698541200 -10800 0 -03}
{1711846800 -7200 1 -02}
{1729990800 -10800 0 -03}
{1743296400 -7200 1 -02}
{1761440400 -10800 0 -03}
{1774746000 -7200 1 -02}
{1792890000 -10800 0 -03}
{1806195600 -7200 1 -02}
{1824944400 -10800 0 -03}
{1837645200 -7200 1 -02}
{1856394000 -10800 0 -03}
{1869094800 -7200 1 -02}
{1887843600 -10800 0 -03}
{1901149200 -7200 1 -02}
{1919293200 -10800 0 -03}
{1932598800 -7200 1 -02}
{1950742800 -10800 0 -03}
{1964048400 -7200 1 -02}
{1982797200 -10800 0 -03}
{1995498000 -7200 1 -02}
{2014246800 -10800 0 -03}
{2026947600 -7200 1 -02}
{2045696400 -10800 0 -03}
{2058397200 -7200 1 -02}
{2077146000 -10800 0 -03}
{2090451600 -7200 1 -02}
{2108595600 -10800 0 -03}
{2121901200 -7200 1 -02}
{2140045200 -10800 0 -03}
{2153350800 -7200 1 -02}
{2172099600 -10800 0 -03}
{2184800400 -7200 1 -02}
{2203549200 -10800 0 -03}
{2216250000 -7200 1 -02}
{2234998800 -10800 0 -03}
{2248304400 -7200 1 -02}
{2266448400 -10800 0 -03}
{2279754000 -7200 1 -02}
{2297898000 -10800 0 -03}
{2311203600 -7200 1 -02}
{2329347600 -10800 0 -03}
{2342653200 -7200 1 -02}
{2361402000 -10800 0 -03}
{2374102800 -7200 1 -02}
{2392851600 -10800 0 -03}
{2405552400 -7200 1 -02}
{2424301200 -10800 0 -03}
{2437606800 -7200 1 -02}
{2455750800 -10800 0 -03}
{2469056400 -7200 1 -02}
{2487200400 -10800 0 -03}
{2500506000 -7200 1 -02}
{2519254800 -10800 0 -03}
{2531955600 -7200 1 -02}
{2550704400 -10800 0 -03}
{2563405200 -7200 1 -02}
{2582154000 -10800 0 -03}
{2595459600 -7200 1 -02}
{2613603600 -10800 0 -03}
{2626909200 -7200 1 -02}
{2645053200 -10800 0 -03}
{2658358800 -7200 1 -02}
{2676502800 -10800 0 -03}
{2689808400 -7200 1 -02}
{2708557200 -10800 0 -03}
{2721258000 -7200 1 -02}
{2740006800 -10800 0 -03}
{2752707600 -7200 1 -02}
{2771456400 -10800 0 -03}
{2784762000 -7200 1 -02}
{2802906000 -10800 0 -03}
{2816211600 -7200 1 -02}
{2834355600 -10800 0 -03}
{2847661200 -7200 1 -02}
{2866410000 -10800 0 -03}
{2879110800 -7200 1 -02}
{2897859600 -10800 0 -03}
{2910560400 -7200 1 -02}
{2929309200 -10800 0 -03}
{2942010000 -7200 1 -02}
{2960758800 -10800 0 -03}
{2974064400 -7200 1 -02}
{2992208400 -10800 0 -03}
{3005514000 -7200 1 -02}
{3023658000 -10800 0 -03}
{3036963600 -7200 1 -02}
{3055712400 -10800 0 -03}
{3068413200 -7200 1 -02}
{3087162000 -10800 0 -03}
{3099862800 -7200 1 -02}
{3118611600 -10800 0 -03}
{3131917200 -7200 1 -02}
{3150061200 -10800 0 -03}
{3163366800 -7200 1 -02}
{3181510800 -10800 0 -03}
{3194816400 -7200 1 -02}
{3212960400 -10800 0 -03}
{3226266000 -7200 1 -02}
{3245014800 -10800 0 -03}
{3257715600 -7200 1 -02}
{3276464400 -10800 0 -03}
{3289165200 -7200 1 -02}
{3307914000 -10800 0 -03}
{3321219600 -7200 1 -02}
{3339363600 -10800 0 -03}
{3352669200 -7200 1 -02}
{3370813200 -10800 0 -03}
{3384118800 -7200 1 -02}
{3402867600 -10800 0 -03}
{3415568400 -7200 1 -02}
{3434317200 -10800 0 -03}
{3447018000 -7200 1 -02}
{3465766800 -10800 0 -03}
{3479072400 -7200 1 -02}
{3497216400 -10800 0 -03}
{3510522000 -7200 1 -02}
{3528666000 -10800 0 -03}
{3541971600 -7200 1 -02}
{3560115600 -10800 0 -03}
{3573421200 -7200 1 -02}
{3592170000 -10800 0 -03}
{3604870800 -7200 1 -02}
{3623619600 -10800 0 -03}
{3636320400 -7200 1 -02}
{3655069200 -10800 0 -03}
{3668374800 -7200 1 -02}
{3686518800 -10800 0 -03}
{3699824400 -7200 1 -02}
{3717968400 -10800 0 -03}
{3731274000 -7200 1 -02}
{3750022800 -10800 0 -03}
{3762723600 -7200 1 -02}
{3781472400 -10800 0 -03}
{3794173200 -7200 1 -02}
{3812922000 -10800 0 -03}
{3825622800 -7200 1 -02}
{3844371600 -10800 0 -03}
{3857677200 -7200 1 -02}
{3875821200 -10800 0 -03}
{3889126800 -7200 1 -02}
{3907270800 -10800 0 -03}
{3920576400 -7200 1 -02}
{3939325200 -10800 0 -03}
{3952026000 -7200 1 -02}
{3970774800 -10800 0 -03}
{3983475600 -7200 1 -02}
{4002224400 -10800 0 -03}
{4015530000 -7200 1 -02}
{4033674000 -10800 0 -03}
{4046979600 -7200 1 -02}
{4065123600 -10800 0 -03}
{4078429200 -7200 1 -02}
{4096573200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Whitehorse.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
| < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 90 91 92 93 94 95 96 97 98 |
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
{1583661600 -25200 1 PDT}
{1604217600 -25200 0 MST}
}
|
Changes to library/tzdata/Antarctica/Casey.
1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
{-31536000 28800 0 +08}
{1255802400 39600 0 +11}
{1267714800 28800 0 +08}
{1319738400 39600 0 +11}
{1329843600 28800 0 +08}
{1477065600 39600 0 +11}
{1520701200 28800 0 +08}
}
| > > > > > | 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(:Antarctica/Casey) {
{-9223372036854775808 0 0 -00}
{-31536000 28800 0 +08}
{1255802400 39600 0 +11}
{1267714800 28800 0 +08}
{1319738400 39600 0 +11}
{1329843600 28800 0 +08}
{1477065600 39600 0 +11}
{1520701200 28800 0 +08}
{1538856000 39600 0 +11}
{1552752000 28800 0 +08}
{1570129200 39600 0 +11}
{1583596800 28800 0 +08}
{1601740860 39600 0 +11}
}
|
Changes to library/tzdata/Antarctica/Macquarie.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Antarctica/Macquarie) {
{-9223372036854775808 0 0 -00}
{-2214259200 36000 0 AEST}
{-1680508800 39600 1 AEDT}
{-1669892400 39600 0 AEDT}
| | | 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(:Antarctica/Macquarie) {
{-9223372036854775808 0 0 -00}
{-2214259200 36000 0 AEST}
{-1680508800 39600 1 AEDT}
{-1669892400 39600 0 AEDT}
{-1665388800 36000 0 AEST}
{-1601719200 0 0 -00}
{-94730400 36000 0 AEST}
{-71136000 39600 1 AEDT}
{-55411200 36000 0 AEST}
{-37267200 39600 1 AEDT}
{-25776000 36000 0 AEST}
{-5817600 39600 1 AEDT}
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1159632000 39600 1 AEDT}
{1174752000 36000 0 AEST}
{1191686400 39600 1 AEDT}
{1207411200 36000 0 AEST}
{1223136000 39600 1 AEDT}
{1238860800 36000 0 AEST}
{1254585600 39600 1 AEDT}
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
{1159632000 39600 1 AEDT}
{1174752000 36000 0 AEST}
{1191686400 39600 1 AEDT}
{1207411200 36000 0 AEST}
{1223136000 39600 1 AEDT}
{1238860800 36000 0 AEST}
{1254585600 39600 1 AEDT}
{1262264400 39600 1 AEDT}
{1293800400 39600 0 AEST}
{1301760000 36000 0 AEST}
{1317484800 39600 1 AEDT}
{1333209600 36000 0 AEST}
{1349539200 39600 1 AEDT}
{1365264000 36000 0 AEST}
{1380988800 39600 1 AEDT}
{1396713600 36000 0 AEST}
{1412438400 39600 1 AEDT}
{1428163200 36000 0 AEST}
{1443888000 39600 1 AEDT}
{1459612800 36000 0 AEST}
{1475337600 39600 1 AEDT}
{1491062400 36000 0 AEST}
{1506787200 39600 1 AEDT}
{1522512000 36000 0 AEST}
{1538841600 39600 1 AEDT}
{1554566400 36000 0 AEST}
{1570291200 39600 1 AEDT}
{1586016000 36000 0 AEST}
{1601740800 39600 1 AEDT}
{1617465600 36000 0 AEST}
{1633190400 39600 1 AEDT}
{1648915200 36000 0 AEST}
{1664640000 39600 1 AEDT}
{1680364800 36000 0 AEST}
{1696089600 39600 1 AEDT}
{1712419200 36000 0 AEST}
{1728144000 39600 1 AEDT}
{1743868800 36000 0 AEST}
{1759593600 39600 1 AEDT}
{1775318400 36000 0 AEST}
{1791043200 39600 1 AEDT}
{1806768000 36000 0 AEST}
{1822492800 39600 1 AEDT}
{1838217600 36000 0 AEST}
{1853942400 39600 1 AEDT}
{1869667200 36000 0 AEST}
{1885996800 39600 1 AEDT}
{1901721600 36000 0 AEST}
{1917446400 39600 1 AEDT}
{1933171200 36000 0 AEST}
{1948896000 39600 1 AEDT}
{1964620800 36000 0 AEST}
{1980345600 39600 1 AEDT}
{1996070400 36000 0 AEST}
{2011795200 39600 1 AEDT}
{2027520000 36000 0 AEST}
{2043244800 39600 1 AEDT}
{2058969600 36000 0 AEST}
{2075299200 39600 1 AEDT}
{2091024000 36000 0 AEST}
{2106748800 39600 1 AEDT}
{2122473600 36000 0 AEST}
{2138198400 39600 1 AEDT}
{2153923200 36000 0 AEST}
{2169648000 39600 1 AEDT}
{2185372800 36000 0 AEST}
{2201097600 39600 1 AEDT}
{2216822400 36000 0 AEST}
{2233152000 39600 1 AEDT}
{2248876800 36000 0 AEST}
{2264601600 39600 1 AEDT}
{2280326400 36000 0 AEST}
{2296051200 39600 1 AEDT}
{2311776000 36000 0 AEST}
{2327500800 39600 1 AEDT}
{2343225600 36000 0 AEST}
{2358950400 39600 1 AEDT}
{2374675200 36000 0 AEST}
{2390400000 39600 1 AEDT}
{2406124800 36000 0 AEST}
{2422454400 39600 1 AEDT}
{2438179200 36000 0 AEST}
{2453904000 39600 1 AEDT}
{2469628800 36000 0 AEST}
{2485353600 39600 1 AEDT}
{2501078400 36000 0 AEST}
{2516803200 39600 1 AEDT}
{2532528000 36000 0 AEST}
{2548252800 39600 1 AEDT}
{2563977600 36000 0 AEST}
{2579702400 39600 1 AEDT}
{2596032000 36000 0 AEST}
{2611756800 39600 1 AEDT}
{2627481600 36000 0 AEST}
{2643206400 39600 1 AEDT}
{2658931200 36000 0 AEST}
{2674656000 39600 1 AEDT}
{2690380800 36000 0 AEST}
{2706105600 39600 1 AEDT}
{2721830400 36000 0 AEST}
{2737555200 39600 1 AEDT}
{2753280000 36000 0 AEST}
{2769609600 39600 1 AEDT}
{2785334400 36000 0 AEST}
{2801059200 39600 1 AEDT}
{2816784000 36000 0 AEST}
{2832508800 39600 1 AEDT}
{2848233600 36000 0 AEST}
{2863958400 39600 1 AEDT}
{2879683200 36000 0 AEST}
{2895408000 39600 1 AEDT}
{2911132800 36000 0 AEST}
{2926857600 39600 1 AEDT}
{2942582400 36000 0 AEST}
{2958912000 39600 1 AEDT}
{2974636800 36000 0 AEST}
{2990361600 39600 1 AEDT}
{3006086400 36000 0 AEST}
{3021811200 39600 1 AEDT}
{3037536000 36000 0 AEST}
{3053260800 39600 1 AEDT}
{3068985600 36000 0 AEST}
{3084710400 39600 1 AEDT}
{3100435200 36000 0 AEST}
{3116764800 39600 1 AEDT}
{3132489600 36000 0 AEST}
{3148214400 39600 1 AEDT}
{3163939200 36000 0 AEST}
{3179664000 39600 1 AEDT}
{3195388800 36000 0 AEST}
{3211113600 39600 1 AEDT}
{3226838400 36000 0 AEST}
{3242563200 39600 1 AEDT}
{3258288000 36000 0 AEST}
{3274012800 39600 1 AEDT}
{3289737600 36000 0 AEST}
{3306067200 39600 1 AEDT}
{3321792000 36000 0 AEST}
{3337516800 39600 1 AEDT}
{3353241600 36000 0 AEST}
{3368966400 39600 1 AEDT}
{3384691200 36000 0 AEST}
{3400416000 39600 1 AEDT}
{3416140800 36000 0 AEST}
{3431865600 39600 1 AEDT}
{3447590400 36000 0 AEST}
{3463315200 39600 1 AEDT}
{3479644800 36000 0 AEST}
{3495369600 39600 1 AEDT}
{3511094400 36000 0 AEST}
{3526819200 39600 1 AEDT}
{3542544000 36000 0 AEST}
{3558268800 39600 1 AEDT}
{3573993600 36000 0 AEST}
{3589718400 39600 1 AEDT}
{3605443200 36000 0 AEST}
{3621168000 39600 1 AEDT}
{3636892800 36000 0 AEST}
{3653222400 39600 1 AEDT}
{3668947200 36000 0 AEST}
{3684672000 39600 1 AEDT}
{3700396800 36000 0 AEST}
{3716121600 39600 1 AEDT}
{3731846400 36000 0 AEST}
{3747571200 39600 1 AEDT}
{3763296000 36000 0 AEST}
{3779020800 39600 1 AEDT}
{3794745600 36000 0 AEST}
{3810470400 39600 1 AEDT}
{3826195200 36000 0 AEST}
{3842524800 39600 1 AEDT}
{3858249600 36000 0 AEST}
{3873974400 39600 1 AEDT}
{3889699200 36000 0 AEST}
{3905424000 39600 1 AEDT}
{3921148800 36000 0 AEST}
{3936873600 39600 1 AEDT}
{3952598400 36000 0 AEST}
{3968323200 39600 1 AEDT}
{3984048000 36000 0 AEST}
{4000377600 39600 1 AEDT}
{4016102400 36000 0 AEST}
{4031827200 39600 1 AEDT}
{4047552000 36000 0 AEST}
{4063276800 39600 1 AEDT}
{4079001600 36000 0 AEST}
{4094726400 39600 1 AEDT}
}
|
Changes to library/tzdata/Asia/Gaza.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Gaza) {
{-9223372036854775808 8272 0 LMT}
{-2185409872 7200 0 EEST}
| | > > | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Gaza) {
{-9223372036854775808 8272 0 LMT}
{-2185409872 7200 0 EEST}
{-933638400 10800 1 EEST}
{-923097600 7200 0 EEST}
{-919036800 10800 1 EEST}
{-857347200 7200 0 EEST}
{-844300800 10800 1 EEST}
{-825811200 7200 0 EEST}
{-812678400 10800 1 EEST}
{-794188800 7200 0 EEST}
{-779846400 10800 1 EEST}
{-762652800 7200 0 EEST}
{-748310400 10800 1 EEST}
{-731116800 7200 0 EEST}
{-682653600 7200 0 EET}
{-399088800 10800 1 EEST}
{-386650800 7200 0 EET}
{-368330400 10800 1 EEST}
{-355114800 7200 0 EET}
{-336790800 10800 1 EEST}
{-323654400 7200 0 EET}
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
| | | | | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334101600 10800 1 IDT}
{337730400 7200 0 IST}
{452642400 10800 1 IDT}
{462319200 7200 0 IST}
{482277600 10800 1 IDT}
{494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
{589323600 7200 0 IST}
{609890400 10800 1 IDT}
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
{1364508000 10800 1 EEST}
{1380229200 7200 0 EET}
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
{1364508000 10800 1 EEST}
{1380229200 7200 0 EET}
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445551200 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553810400 10800 1 EEST}
{1572037200 7200 0 EET}
{1585346400 10800 1 EEST}
{1603490400 7200 0 EET}
{1616796000 10800 1 EEST}
{1635544800 7200 0 EET}
{1648245600 10800 1 EEST}
{1666994400 7200 0 EET}
{1679695200 10800 1 EEST}
{1698444000 7200 0 EET}
{1711749600 10800 1 EEST}
{1729893600 7200 0 EET}
{1743199200 10800 1 EEST}
{1761343200 7200 0 EET}
{1774648800 10800 1 EEST}
{1792792800 7200 0 EET}
{1806098400 10800 1 EEST}
{1824847200 7200 0 EET}
{1837548000 10800 1 EEST}
{1856296800 7200 0 EET}
{1868997600 10800 1 EEST}
{1887746400 7200 0 EET}
{1901052000 10800 1 EEST}
{1919196000 7200 0 EET}
{1932501600 10800 1 EEST}
{1950645600 7200 0 EET}
{1963951200 10800 1 EEST}
{1982700000 7200 0 EET}
{1995400800 10800 1 EEST}
{2014149600 7200 0 EET}
{2026850400 10800 1 EEST}
{2045599200 7200 0 EET}
{2058300000 10800 1 EEST}
{2077048800 7200 0 EET}
{2090354400 10800 1 EEST}
{2108498400 7200 0 EET}
{2121804000 10800 1 EEST}
{2139948000 7200 0 EET}
{2153253600 10800 1 EEST}
{2172002400 7200 0 EET}
{2184703200 10800 1 EEST}
{2203452000 7200 0 EET}
{2216152800 10800 1 EEST}
{2234901600 7200 0 EET}
{2248207200 10800 1 EEST}
{2266351200 7200 0 EET}
{2279656800 10800 1 EEST}
{2297800800 7200 0 EET}
{2311106400 10800 1 EEST}
{2329250400 7200 0 EET}
{2342556000 10800 1 EEST}
{2361304800 7200 0 EET}
{2374005600 10800 1 EEST}
{2392754400 7200 0 EET}
{2405455200 10800 1 EEST}
{2424204000 7200 0 EET}
{2437509600 10800 1 EEST}
{2455653600 7200 0 EET}
{2468959200 10800 1 EEST}
{2487103200 7200 0 EET}
{2500408800 10800 1 EEST}
{2519157600 7200 0 EET}
{2531858400 10800 1 EEST}
{2550607200 7200 0 EET}
{2563308000 10800 1 EEST}
{2582056800 7200 0 EET}
{2595362400 10800 1 EEST}
{2613506400 7200 0 EET}
{2626812000 10800 1 EEST}
{2644956000 7200 0 EET}
{2658261600 10800 1 EEST}
{2676405600 7200 0 EET}
{2689711200 10800 1 EEST}
{2708460000 7200 0 EET}
{2721160800 10800 1 EEST}
{2739909600 7200 0 EET}
{2752610400 10800 1 EEST}
{2771359200 7200 0 EET}
{2784664800 10800 1 EEST}
{2802808800 7200 0 EET}
{2816114400 10800 1 EEST}
{2834258400 7200 0 EET}
{2847564000 10800 1 EEST}
{2866312800 7200 0 EET}
{2879013600 10800 1 EEST}
{2897762400 7200 0 EET}
{2910463200 10800 1 EEST}
{2929212000 7200 0 EET}
{2941912800 10800 1 EEST}
{2960661600 7200 0 EET}
{2973967200 10800 1 EEST}
{2992111200 7200 0 EET}
{3005416800 10800 1 EEST}
{3023560800 7200 0 EET}
{3036866400 10800 1 EEST}
{3055615200 7200 0 EET}
{3068316000 10800 1 EEST}
{3087064800 7200 0 EET}
{3099765600 10800 1 EEST}
{3118514400 7200 0 EET}
{3131820000 10800 1 EEST}
{3149964000 7200 0 EET}
{3163269600 10800 1 EEST}
{3181413600 7200 0 EET}
{3194719200 10800 1 EEST}
{3212863200 7200 0 EET}
{3226168800 10800 1 EEST}
{3244917600 7200 0 EET}
{3257618400 10800 1 EEST}
{3276367200 7200 0 EET}
{3289068000 10800 1 EEST}
{3307816800 7200 0 EET}
{3321122400 10800 1 EEST}
{3339266400 7200 0 EET}
{3352572000 10800 1 EEST}
{3370716000 7200 0 EET}
{3384021600 10800 1 EEST}
{3402770400 7200 0 EET}
{3415471200 10800 1 EEST}
{3434220000 7200 0 EET}
{3446920800 10800 1 EEST}
{3465669600 7200 0 EET}
{3478975200 10800 1 EEST}
{3497119200 7200 0 EET}
{3510424800 10800 1 EEST}
{3528568800 7200 0 EET}
{3541874400 10800 1 EEST}
{3560018400 7200 0 EET}
{3573324000 10800 1 EEST}
{3592072800 7200 0 EET}
{3604773600 10800 1 EEST}
{3623522400 7200 0 EET}
{3636223200 10800 1 EEST}
{3654972000 7200 0 EET}
{3668277600 10800 1 EEST}
{3686421600 7200 0 EET}
{3699727200 10800 1 EEST}
{3717871200 7200 0 EET}
{3731176800 10800 1 EEST}
{3749925600 7200 0 EET}
{3762626400 10800 1 EEST}
{3781375200 7200 0 EET}
{3794076000 10800 1 EEST}
{3812824800 7200 0 EET}
{3825525600 10800 1 EEST}
{3844274400 7200 0 EET}
{3857580000 10800 1 EEST}
{3875724000 7200 0 EET}
{3889029600 10800 1 EEST}
{3907173600 7200 0 EET}
{3920479200 10800 1 EEST}
{3939228000 7200 0 EET}
{3951928800 10800 1 EEST}
{3970677600 7200 0 EET}
{3983378400 10800 1 EEST}
{4002127200 7200 0 EET}
{4015432800 10800 1 EEST}
{4033576800 7200 0 EET}
{4046882400 10800 1 EEST}
{4065026400 7200 0 EET}
{4078332000 10800 1 EEST}
{4096476000 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hebron.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hebron) {
{-9223372036854775808 8423 0 LMT}
{-2185410023 7200 0 EEST}
| | > > | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hebron) {
{-9223372036854775808 8423 0 LMT}
{-2185410023 7200 0 EEST}
{-933638400 10800 1 EEST}
{-923097600 7200 0 EEST}
{-919036800 10800 1 EEST}
{-857347200 7200 0 EEST}
{-844300800 10800 1 EEST}
{-825811200 7200 0 EEST}
{-812678400 10800 1 EEST}
{-794188800 7200 0 EEST}
{-779846400 10800 1 EEST}
{-762652800 7200 0 EEST}
{-748310400 10800 1 EEST}
{-731116800 7200 0 EEST}
{-682653600 7200 0 EET}
{-399088800 10800 1 EEST}
{-386650800 7200 0 EET}
{-368330400 10800 1 EEST}
{-355114800 7200 0 EET}
{-336790800 10800 1 EEST}
{-323654400 7200 0 EET}
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
| | | | | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
{-102643200 7200 0 EET}
{-84330000 10800 1 EEST}
{-81313200 10800 0 IST}
{142376400 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334101600 10800 1 IDT}
{337730400 7200 0 IST}
{452642400 10800 1 IDT}
{462319200 7200 0 IST}
{482277600 10800 1 IDT}
{494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
{589323600 7200 0 IST}
{609890400 10800 1 IDT}
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
{1364508000 10800 1 EEST}
{1380229200 7200 0 EET}
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1333058400 10800 1 EEST}
{1348178400 7200 0 EET}
{1364508000 10800 1 EEST}
{1380229200 7200 0 EET}
{1395957600 10800 1 EEST}
{1414098000 7200 0 EET}
{1427493600 10800 1 EEST}
{1445551200 7200 0 EET}
{1458946800 10800 1 EEST}
{1477692000 7200 0 EET}
{1490396400 10800 1 EEST}
{1509141600 7200 0 EET}
{1521846000 10800 1 EEST}
{1540591200 7200 0 EET}
{1553810400 10800 1 EEST}
{1572037200 7200 0 EET}
{1585346400 10800 1 EEST}
{1603490400 7200 0 EET}
{1616796000 10800 1 EEST}
{1635544800 7200 0 EET}
{1648245600 10800 1 EEST}
{1666994400 7200 0 EET}
{1679695200 10800 1 EEST}
{1698444000 7200 0 EET}
{1711749600 10800 1 EEST}
{1729893600 7200 0 EET}
{1743199200 10800 1 EEST}
{1761343200 7200 0 EET}
{1774648800 10800 1 EEST}
{1792792800 7200 0 EET}
{1806098400 10800 1 EEST}
{1824847200 7200 0 EET}
{1837548000 10800 1 EEST}
{1856296800 7200 0 EET}
{1868997600 10800 1 EEST}
{1887746400 7200 0 EET}
{1901052000 10800 1 EEST}
{1919196000 7200 0 EET}
{1932501600 10800 1 EEST}
{1950645600 7200 0 EET}
{1963951200 10800 1 EEST}
{1982700000 7200 0 EET}
{1995400800 10800 1 EEST}
{2014149600 7200 0 EET}
{2026850400 10800 1 EEST}
{2045599200 7200 0 EET}
{2058300000 10800 1 EEST}
{2077048800 7200 0 EET}
{2090354400 10800 1 EEST}
{2108498400 7200 0 EET}
{2121804000 10800 1 EEST}
{2139948000 7200 0 EET}
{2153253600 10800 1 EEST}
{2172002400 7200 0 EET}
{2184703200 10800 1 EEST}
{2203452000 7200 0 EET}
{2216152800 10800 1 EEST}
{2234901600 7200 0 EET}
{2248207200 10800 1 EEST}
{2266351200 7200 0 EET}
{2279656800 10800 1 EEST}
{2297800800 7200 0 EET}
{2311106400 10800 1 EEST}
{2329250400 7200 0 EET}
{2342556000 10800 1 EEST}
{2361304800 7200 0 EET}
{2374005600 10800 1 EEST}
{2392754400 7200 0 EET}
{2405455200 10800 1 EEST}
{2424204000 7200 0 EET}
{2437509600 10800 1 EEST}
{2455653600 7200 0 EET}
{2468959200 10800 1 EEST}
{2487103200 7200 0 EET}
{2500408800 10800 1 EEST}
{2519157600 7200 0 EET}
{2531858400 10800 1 EEST}
{2550607200 7200 0 EET}
{2563308000 10800 1 EEST}
{2582056800 7200 0 EET}
{2595362400 10800 1 EEST}
{2613506400 7200 0 EET}
{2626812000 10800 1 EEST}
{2644956000 7200 0 EET}
{2658261600 10800 1 EEST}
{2676405600 7200 0 EET}
{2689711200 10800 1 EEST}
{2708460000 7200 0 EET}
{2721160800 10800 1 EEST}
{2739909600 7200 0 EET}
{2752610400 10800 1 EEST}
{2771359200 7200 0 EET}
{2784664800 10800 1 EEST}
{2802808800 7200 0 EET}
{2816114400 10800 1 EEST}
{2834258400 7200 0 EET}
{2847564000 10800 1 EEST}
{2866312800 7200 0 EET}
{2879013600 10800 1 EEST}
{2897762400 7200 0 EET}
{2910463200 10800 1 EEST}
{2929212000 7200 0 EET}
{2941912800 10800 1 EEST}
{2960661600 7200 0 EET}
{2973967200 10800 1 EEST}
{2992111200 7200 0 EET}
{3005416800 10800 1 EEST}
{3023560800 7200 0 EET}
{3036866400 10800 1 EEST}
{3055615200 7200 0 EET}
{3068316000 10800 1 EEST}
{3087064800 7200 0 EET}
{3099765600 10800 1 EEST}
{3118514400 7200 0 EET}
{3131820000 10800 1 EEST}
{3149964000 7200 0 EET}
{3163269600 10800 1 EEST}
{3181413600 7200 0 EET}
{3194719200 10800 1 EEST}
{3212863200 7200 0 EET}
{3226168800 10800 1 EEST}
{3244917600 7200 0 EET}
{3257618400 10800 1 EEST}
{3276367200 7200 0 EET}
{3289068000 10800 1 EEST}
{3307816800 7200 0 EET}
{3321122400 10800 1 EEST}
{3339266400 7200 0 EET}
{3352572000 10800 1 EEST}
{3370716000 7200 0 EET}
{3384021600 10800 1 EEST}
{3402770400 7200 0 EET}
{3415471200 10800 1 EEST}
{3434220000 7200 0 EET}
{3446920800 10800 1 EEST}
{3465669600 7200 0 EET}
{3478975200 10800 1 EEST}
{3497119200 7200 0 EET}
{3510424800 10800 1 EEST}
{3528568800 7200 0 EET}
{3541874400 10800 1 EEST}
{3560018400 7200 0 EET}
{3573324000 10800 1 EEST}
{3592072800 7200 0 EET}
{3604773600 10800 1 EEST}
{3623522400 7200 0 EET}
{3636223200 10800 1 EEST}
{3654972000 7200 0 EET}
{3668277600 10800 1 EEST}
{3686421600 7200 0 EET}
{3699727200 10800 1 EEST}
{3717871200 7200 0 EET}
{3731176800 10800 1 EEST}
{3749925600 7200 0 EET}
{3762626400 10800 1 EEST}
{3781375200 7200 0 EET}
{3794076000 10800 1 EEST}
{3812824800 7200 0 EET}
{3825525600 10800 1 EEST}
{3844274400 7200 0 EET}
{3857580000 10800 1 EEST}
{3875724000 7200 0 EET}
{3889029600 10800 1 EEST}
{3907173600 7200 0 EET}
{3920479200 10800 1 EEST}
{3939228000 7200 0 EET}
{3951928800 10800 1 EEST}
{3970677600 7200 0 EET}
{3983378400 10800 1 EEST}
{4002127200 7200 0 EET}
{4015432800 10800 1 EEST}
{4033576800 7200 0 EET}
{4046882400 10800 1 EEST}
{4065026400 7200 0 EET}
{4078332000 10800 1 EEST}
{4096476000 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Jerusalem.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jerusalem) {
{-9223372036854775808 8454 0 LMT}
{-2840149254 8440 0 JMT}
{-1641003640 7200 0 IST}
| | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Jerusalem) {
{-9223372036854775808 8454 0 LMT}
{-2840149254 8440 0 JMT}
{-1641003640 7200 0 IST}
{-933638400 10800 1 IDT}
{-923097600 7200 0 IST}
{-919036800 10800 1 IDT}
{-857347200 7200 0 IST}
{-844300800 10800 1 IDT}
{-825811200 7200 0 IST}
{-812678400 10800 1 IDT}
{-794188800 7200 0 IST}
{-779846400 10800 1 IDT}
{-762652800 7200 0 IST}
{-748310400 10800 1 IDT}
{-731116800 7200 0 IST}
{-681955200 14400 1 IDDT}
{-673228800 10800 1 IDT}
{-667958400 7200 0 IST}
{-652320000 10800 1 IDT}
{-636422400 7200 0 IST}
{-622080000 10800 1 IDT}
{-608947200 7200 0 IST}
{-591840000 10800 1 IDT}
{-572486400 7200 0 IST}
{-558576000 10800 1 IDT}
{-542851200 7200 0 IST}
{-527731200 10800 1 IDT}
{-514425600 7200 0 IST}
{-490838400 10800 1 IDT}
{-482976000 7200 0 IST}
{-459388800 10800 1 IDT}
{-451526400 7200 0 IST}
{-428544000 10800 1 IDT}
{-418262400 7200 0 IST}
{-400118400 10800 1 IDT}
{-387417600 7200 0 IST}
{142380000 10800 1 IDT}
{150843600 7200 0 IST}
{167176800 10800 1 IDT}
{178664400 7200 0 IST}
{334101600 10800 1 IDT}
{337730400 7200 0 IST}
{452642400 10800 1 IDT}
{462319200 7200 0 IST}
{482277600 10800 1 IDT}
{494370000 7200 0 IST}
{516751200 10800 1 IDT}
{526424400 7200 0 IST}
{545436000 10800 1 IDT}
{558478800 7200 0 IST}
{576626400 10800 1 IDT}
{589323600 7200 0 IST}
{609890400 10800 1 IDT}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Shanghai.
1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
| > > | 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/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-1600675200 32400 1 CDT}
{-1585904400 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
|
| ︙ | ︙ |
Changes to library/tzdata/Atlantic/Bermuda.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Atlantic/Bermuda) {
{-9223372036854775808 -15558 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(:Atlantic/Bermuda) {
{-9223372036854775808 -15558 0 LMT}
{-2524506042 -15558 0 BMT}
{-1664307642 -11958 1 BMT}
{-1648932042 -15558 0 BMT}
{-1632080442 -11958 1 BMT}
{-1618692042 -15558 0 BST}
{-1262281242 -14400 0 AT}
{-882727200 -10800 1 ADT}
{-858538800 -14400 0 AST}
{-845229600 -10800 1 ADT}
{-825879600 -14400 0 AST}
{-814384800 -10800 1 ADT}
{-793825200 -14400 0 AST}
{-782935200 -10800 1 ADT}
{-762375600 -14400 0 AST}
{-713988000 -10800 1 ADT}
{-703710000 -14400 0 AST}
{-681933600 -10800 1 ADT}
{-672865200 -14400 0 AST}
{-650484000 -10800 1 ADT}
{-641415600 -14400 0 AST}
{-618429600 -10800 1 ADT}
{-609966000 -14400 0 AST}
{-586980000 -10800 1 ADT}
{-578516400 -14400 0 AST}
{-555530400 -10800 1 ADT}
{-546462000 -14400 0 AST}
{-429127200 -10800 1 ADT}
{-415825200 -14400 0 AST}
{136360800 -10800 0 ADT}
{152082000 -14400 0 AST}
{167810400 -10800 1 ADT}
{183531600 -14400 0 AST}
{189316800 -14400 0 AST}
{199260000 -10800 1 ADT}
{215586000 -14400 0 AST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Adelaide.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Adelaide) {
{-9223372036854775808 33260 0 LMT}
{-2364110060 32400 0 ACST}
{-2230189200 34200 0 ACST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Adelaide) {
{-9223372036854775808 33260 0 LMT}
{-2364110060 32400 0 ACST}
{-2230189200 34200 0 ACST}
{-1672558200 37800 1 ACDT}
{-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
{-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
{-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
{-813223800 34200 0 ACST}
{31501800 34200 0 ACST}
{57688200 37800 1 ACDT}
{67969800 34200 0 ACST}
{89137800 37800 1 ACDT}
{100024200 34200 0 ACST}
{120587400 37800 1 ACDT}
{131473800 34200 0 ACST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Brisbane.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Brisbane) {
{-9223372036854775808 36728 0 LMT}
{-2366791928 36000 0 AEST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Brisbane) {
{-9223372036854775808 36728 0 LMT}
{-2366791928 36000 0 AEST}
{-1672560000 39600 1 AEDT}
{-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
{-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
{-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
{-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
{625593600 39600 1 AEDT}
{636480000 36000 0 AEST}
{657043200 39600 1 AEDT}
{667929600 36000 0 AEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Broken_Hill.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Broken_Hill) {
{-9223372036854775808 33948 0 LMT}
{-2364110748 36000 0 AEST}
{-2314951200 32400 0 ACST}
{-2230189200 34200 0 ACST}
| | | | | | | 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(:Australia/Broken_Hill) {
{-9223372036854775808 33948 0 LMT}
{-2364110748 36000 0 AEST}
{-2314951200 32400 0 ACST}
{-2230189200 34200 0 ACST}
{-1672558200 37800 1 ACDT}
{-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
{-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
{-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
{-813223800 34200 0 ACST}
{31501800 34200 0 ACST}
{57688200 37800 1 ACDT}
{67969800 34200 0 ACST}
{89137800 37800 1 ACDT}
{100024200 34200 0 ACST}
{120587400 37800 1 ACDT}
{131473800 34200 0 ACST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Currie.
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(Australia/Hobart)]} {
LoadTimeZoneFile Australia/Hobart
}
set TZData(:Australia/Currie) $TZData(:Australia/Hobart)
|
Changes to library/tzdata/Australia/Darwin.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Darwin) {
{-9223372036854775808 31400 0 LMT}
{-2364108200 32400 0 ACST}
{-2230189200 34200 0 ACST}
| | | | | | | 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(:Australia/Darwin) {
{-9223372036854775808 31400 0 LMT}
{-2364108200 32400 0 ACST}
{-2230189200 34200 0 ACST}
{-1672558200 37800 1 ACDT}
{-1665387000 34200 0 ACST}
{-883639800 37800 1 ACDT}
{-876123000 34200 0 ACST}
{-860398200 37800 1 ACDT}
{-844673400 34200 0 ACST}
{-828343800 37800 1 ACDT}
{-813223800 34200 0 ACST}
}
|
Changes to library/tzdata/Australia/Eucla.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Eucla) {
{-9223372036854775808 30928 0 LMT}
{-2337928528 31500 0 +0945}
| | | | | | 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(:Australia/Eucla) {
{-9223372036854775808 30928 0 LMT}
{-2337928528 31500 0 +0945}
{-1672555500 35100 1 +0945}
{-1665384300 31500 0 +0945}
{-883637100 35100 1 +0945}
{-876120300 31500 0 +0945}
{-860395500 35100 1 +0945}
{-844670700 31500 0 +0945}
{-836473500 35100 0 +0945}
{152039700 35100 1 +0945}
{162926100 31500 0 +0945}
{436295700 35100 1 +0945}
{447182100 31500 0 +0945}
{690311700 35100 1 +0945}
{699383700 31500 0 +0945}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Hobart.
1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Hobart) {
{-9223372036854775808 35356 0 LMT}
{-2345795356 36000 0 AEST}
{-1680508800 39600 1 AEDT}
| > > > | | > | | | | 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/Hobart) {
{-9223372036854775808 35356 0 LMT}
{-2345795356 36000 0 AEST}
{-1680508800 39600 1 AEDT}
{-1665388800 36000 0 AEST}
{-1646640000 39600 1 AEDT}
{-1635753600 36000 0 AEST}
{-1615190400 39600 1 AEDT}
{-1604304000 36000 0 AEST}
{-1583920800 36000 0 AEST}
{-883641600 39600 1 AEDT}
{-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
{-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
{-813225600 36000 0 AEST}
{-94730400 36000 0 AEST}
{-71136000 39600 1 AEDT}
{-55411200 36000 0 AEST}
{-37267200 39600 1 AEDT}
{-25776000 36000 0 AEST}
{-5817600 39600 1 AEDT}
{5673600 36000 0 AEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Lindeman.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lindeman) {
{-9223372036854775808 35756 0 LMT}
{-2366790956 36000 0 AEST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Lindeman) {
{-9223372036854775808 35756 0 LMT}
{-2366790956 36000 0 AEST}
{-1672560000 39600 1 AEDT}
{-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
{-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
{-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
{-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
{625593600 39600 1 AEDT}
{636480000 36000 0 AEST}
{657043200 39600 1 AEDT}
{667929600 36000 0 AEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Melbourne.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Melbourne) {
{-9223372036854775808 34792 0 LMT}
{-2364111592 36000 0 AEST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Melbourne) {
{-9223372036854775808 34792 0 LMT}
{-2364111592 36000 0 AEST}
{-1672560000 39600 1 AEDT}
{-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
{-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
{-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
{-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
{89136000 39600 1 AEDT}
{100022400 36000 0 AEST}
{120585600 39600 1 AEDT}
{131472000 36000 0 AEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Perth.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Perth) {
{-9223372036854775808 27804 0 LMT}
{-2337925404 28800 0 AWST}
| | | | | | 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(:Australia/Perth) {
{-9223372036854775808 27804 0 LMT}
{-2337925404 28800 0 AWST}
{-1672552800 32400 1 AWDT}
{-1665381600 28800 0 AWST}
{-883634400 32400 1 AWDT}
{-876117600 28800 0 AWST}
{-860392800 32400 1 AWDT}
{-844668000 28800 0 AWST}
{-836470800 32400 0 AWST}
{152042400 32400 1 AWDT}
{162928800 28800 0 AWST}
{436298400 32400 1 AWDT}
{447184800 28800 0 AWST}
{690314400 32400 1 AWDT}
{699386400 28800 0 AWST}
|
| ︙ | ︙ |
Changes to library/tzdata/Australia/Sydney.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Sydney) {
{-9223372036854775808 36292 0 LMT}
{-2364113092 36000 0 AEST}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Australia/Sydney) {
{-9223372036854775808 36292 0 LMT}
{-2364113092 36000 0 AEST}
{-1672560000 39600 1 AEDT}
{-1665388800 36000 0 AEST}
{-883641600 39600 1 AEDT}
{-876124800 36000 0 AEST}
{-860400000 39600 1 AEDT}
{-844675200 36000 0 AEST}
{-828345600 39600 1 AEDT}
{-813225600 36000 0 AEST}
{31500000 36000 0 AEST}
{57686400 39600 1 AEDT}
{67968000 36000 0 AEST}
{89136000 39600 1 AEDT}
{100022400 36000 0 AEST}
{120585600 39600 1 AEDT}
{131472000 36000 0 AEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Budapest.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Budapest) {
{-9223372036854775808 4580 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Budapest) {
{-9223372036854775808 4580 0 LMT}
{-2498260580 3600 0 CET}
{-1693706400 7200 1 CEST}
{-1680483600 3600 0 CET}
{-1663455600 7200 1 CEST}
{-1650150000 3600 0 CET}
{-1640998800 3600 0 CET}
{-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
{-1600470000 7200 1 CEST}
{-1587250800 3600 0 CET}
{-1569711600 7200 1 CEST}
{-1555196400 3600 0 CET}
{-906775200 3600 0 CET}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-788922000 3600 0 CET}
{-778471200 7200 1 CEST}
{-762656400 3600 0 CET}
{-749689200 7200 1 CEST}
{-733276800 3600 0 CET}
{-717634800 7200 1 CEST}
{-701910000 3600 0 CET}
{-686185200 7200 1 CEST}
{-670460400 3600 0 CET}
{-654130800 7200 1 CEST}
{-639010800 3600 0 CET}
{-492656400 7200 1 CEST}
{-481168800 3600 0 CET}
{-461199600 7200 1 CEST}
{-449708400 3600 0 CET}
{-428540400 7200 1 CEST}
{-418258800 3600 0 CET}
{-397090800 7200 1 CEST}
{-386809200 3600 0 CET}
{323823600 7200 1 CEST}
{338943600 3600 0 CET}
{354668400 7200 1 CEST}
{370393200 3600 0 CET}
{386118000 7200 1 CEST}
{401842800 3600 0 CET}
{417567600 7200 1 CEST}
{433292400 3600 0 CET}
{441759600 3600 0 CET}
{449024400 7200 1 CEST}
{465354000 3600 0 CET}
{481078800 7200 1 CEST}
{496803600 3600 0 CET}
{512528400 7200 1 CEST}
{528253200 3600 0 CET}
{543978000 7200 1 CEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Monaco.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Monaco) {
{-9223372036854775808 1772 0 LMT}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Monaco) {
{-9223372036854775808 1772 0 LMT}
{-2448318572 561 0 PMT}
{-1854403761 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
{-1665363600 3600 1 WEST}
{-1648342800 0 0 WET}
{-1635123600 3600 1 WEST}
{-1616893200 0 0 WET}
{-1604278800 3600 1 WEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Paris.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Paris) {
{-9223372036854775808 561 0 LMT}
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Paris) {
{-9223372036854775808 561 0 LMT}
{-2486592561 561 0 PMT}
{-1855958961 0 0 WET}
{-1689814800 3600 1 WEST}
{-1680397200 0 0 WET}
{-1665363600 3600 1 WEST}
{-1648342800 0 0 WET}
{-1635123600 3600 1 WEST}
{-1616893200 0 0 WET}
{-1604278800 3600 1 WEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Volgograd.
| ︙ | ︙ | |||
65 66 67 68 69 70 71 72 |
{1238281200 14400 1 +04}
{1256425200 10800 0 +03}
{1269730800 14400 1 +04}
{1288479600 10800 0 +03}
{1301180400 14400 0 +04}
{1414274400 10800 0 +03}
{1540681200 14400 0 +04}
}
| > | 65 66 67 68 69 70 71 72 73 |
{1238281200 14400 1 +04}
{1256425200 10800 0 +03}
{1269730800 14400 1 +04}
{1288479600 10800 0 +03}
{1301180400 14400 0 +04}
{1414274400 10800 0 +03}
{1540681200 14400 0 +04}
{1609020000 10800 0 +03}
}
|
Changes to library/tzdata/Indian/Mahe.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mahe) {
{-9223372036854775808 13308 0 LMT}
| | | 1 2 3 4 5 6 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Indian/Mahe) {
{-9223372036854775808 13308 0 LMT}
{-1988163708 14400 0 +04}
}
|
Changes to library/tzdata/Pacific/Efate.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +11}
{433256400 43200 1 +11}
{448977600 39600 0 +11}
| > > | | 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(:Pacific/Efate) {
{-9223372036854775808 40396 0 LMT}
{-1829387596 39600 0 +11}
{125409600 43200 1 +11}
{133876800 39600 0 +11}
{433256400 43200 1 +11}
{448977600 39600 0 +11}
{464706000 43200 1 +11}
{480427200 39600 0 +11}
{496760400 43200 1 +11}
{511876800 39600 0 +11}
{528210000 43200 1 +11}
{543931200 39600 0 +11}
{559659600 43200 1 +11}
{575380800 39600 0 +11}
|
| ︙ | ︙ |
Changes to library/tzdata/Pacific/Fiji.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 |
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
{1573308000 46800 1 +12}
{1578751200 43200 0 +12}
| | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
{1573308000 46800 1 +12}
{1578751200 43200 0 +12}
{1608386400 46800 1 +12}
{1610805600 43200 0 +12}
{1636812000 46800 1 +12}
{1642255200 43200 0 +12}
{1668261600 46800 1 +12}
{1673704800 43200 0 +12}
{1699711200 46800 1 +12}
{1705154400 43200 0 +12}
|
| ︙ | ︙ |
Changes to library/word.tcl.
1 2 3 4 5 6 | # word.tcl -- # # This file defines various procedures for computing word boundaries in # strings. This file is primarily needed so Tk text and entry widgets behave # properly for different platforms. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # word.tcl -- # # This file defines various procedures for computing word boundaries in # strings. This file is primarily needed so Tk text and entry widgets behave # properly for different platforms. # # Copyright © 1996 Sun Microsystems, Inc. # Copyright © 1998 Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # The following variables are used to determine which characters are # interpreted as word characters. See bug [f1253530cdd8]. Will # probably be removed in Tcl 9. |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
| > | | > | 132 133 134 135 136 137 138 139 140 141 142 143 144 |
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
if {$start > 0} {
regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
result word
}
return [lindex $word 0]
}
|
Changes to libtommath/libtommath_VS2008.sln.
| ︙ | ︙ |
Changes to libtommath/tommath_private.h.
| ︙ | ︙ | |||
190 191 192 193 194 195 196 197 198 199 200 201 202 203 | #define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(uintmax_t) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT) 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; | > > > | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
#define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(uintmax_t) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT)
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);
#ifdef __cplusplus
extern "C" {
#endif
/* 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;
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
int redmode);
MP_DEPRECATED(s_mp_invmod_slow) mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_mul) mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_sqr) mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len);
#ifndef TCL_WITH_EXTERNAL_TOMMATH
#undef mp_sqr
#define mp_sqr TclBN_mp_sqr
#endif
#define MP_GET_ENDIANNESS(x) \
| > > > > | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
int redmode);
MP_DEPRECATED(s_mp_invmod_slow) mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_mul) mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_sqr) mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len);
#ifdef __cplusplus
}
#endif
#ifndef TCL_WITH_EXTERNAL_TOMMATH
#undef mp_sqr
#define mp_sqr TclBN_mp_sqr
#endif
#define MP_GET_ENDIANNESS(x) \
|
| ︙ | ︙ |
Changes to macosx/GNUmakefile.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
PREFIX ?= /usr/local
BINDIR ?= ${PREFIX}/bin
LIBDIR ?= ${INSTALL_PATH}
MANDIR ?= ${PREFIX}/man
# set to non-empty value to install manpages in addition to html help:
INSTALL_MANPAGES ?=
#-------------------------------------------------------------------------------------------------------
# meta targets
meta := all install embedded install-embedded clean distclean test
styles := develop deploy
| > > > > > > > > > > > > | 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 |
PREFIX ?= /usr/local
BINDIR ?= ${PREFIX}/bin
LIBDIR ?= ${INSTALL_PATH}
MANDIR ?= ${PREFIX}/man
# set to non-empty value to install manpages in addition to html help:
INSTALL_MANPAGES ?=
# Checks and overrides for subframework builds
ifeq (${SUBFRAMEWORK},1)
ifeq (${DYLIB_INSTALL_DIR},)
@echo "Cannot install subframework with empty DYLIB_INSTALL_DIR !" && false
endif
ifeq (${DESTDIR},)
@echo "Cannot install subframework with empty DESTDIR !" && false
endif
override BUILD_DIR = ${DESTDIR}/build
override INSTALL_PATH = /Frameworks
endif
#-------------------------------------------------------------------------------------------------------
# meta targets
meta := all install embedded install-embedded clean distclean test
styles := develop deploy
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
OBJ_DIR = ${OBJROOT}/${BUILD_STYLE}
empty :=
space := ${empty} ${empty}
objdir = $(subst ${space},\ ,${OBJ_DIR})
develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
OBJ_DIR = ${OBJROOT}/${BUILD_STYLE}
empty :=
space := ${empty} ${empty}
objdir = $(subst ${space},\ ,${OBJ_DIR})
develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols
deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install \
EXTRA_CFLAGS=-DNDEBUG
embedded_make_args := EMBEDDED_BUILD=1
install_make_args := INSTALL_BUILD=1
${targets}:
${MAKE} ${action}${PROJECT} \
$(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args}))
|
| ︙ | ︙ |
Changes to macosx/README.
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
(c.f. man dyld for more details)
If you only want to build and install the debug or optimized build, use the
'develop' or 'deploy' target variants of the GNUmakefile, respectively.
For example, to build and install only the optimized versions:
make -C tcl${ver}/macosx deploy
sudo make -C tcl${ver}/macosx install-deploy
| > > > > > > > > > > | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
(c.f. man dyld for more details)
If you only want to build and install the debug or optimized build, use the
'develop' or 'deploy' target variants of the GNUmakefile, respectively.
For example, to build and install only the optimized versions:
make -C tcl${ver}/macosx deploy
sudo make -C tcl${ver}/macosx install-deploy
- To build a Tcl.framework for use as a subframework in another framework, use the
install-embedded target and set SUBFRAMEWORK=1. Set the DYLIB_INSTALL_DIR
variable to the path which should be the install_name path of the Tcl library, set
the DESTDIR variable to the pathname of a staging directory where the framework
will be written . For example, running this command in the Tcl source directory:
make -C macosx install-embedded SUBFRAMEWORK=1 DESTDIR=/tmp/tcl \
DYLIB_INSTALL_DIR=/Library/Frameworks/Some.framework/Versions/X.Y/Frameworks/Tcl.framework
will produce a Tcl.framework intended for installing as a subframework of
Some.framework. The framework will be found in /tmp/tcl/Frameworks/
|
Changes to macosx/Tcl-Common.xcconfig.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | INSTALL_MODE_FLAG = go-w,a+rX GCC_PREFIX_HEADER = $(DERIVED_FILE_DIR)/tcl/tclConfig.h GCC_GENERATE_DEBUGGING_SYMBOLS = YES GCC_NO_COMMON_BLOCKS = YES GCC_DYNAMIC_NO_PIC = YES GCC_VERSION = 4.2 GCC = gcc-$(GCC_VERSION) | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | INSTALL_MODE_FLAG = go-w,a+rX GCC_PREFIX_HEADER = $(DERIVED_FILE_DIR)/tcl/tclConfig.h GCC_GENERATE_DEBUGGING_SYMBOLS = YES GCC_NO_COMMON_BLOCKS = YES GCC_DYNAMIC_NO_PIC = YES GCC_VERSION = 4.2 GCC = gcc-$(GCC_VERSION) WARNING_CFLAGS = -Wall -Wextra -Wshadow -Wwrite-strings -Wpointer-arith -Wc++-compat -Wdeclaration-after-statement -Winit-self -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS) BINDIR = $(PREFIX)/bin CFLAGS = $(CFLAGS) CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS) FRAMEWORK_INSTALL_PATH = /Library/Frameworks INCLUDEDIR = $(PREFIX)/include LIBDIR = $(PREFIX)/lib MANDIR = $(PREFIX)/man |
| ︙ | ︙ |
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = "<group>"; };
F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = "<group>"; };
F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = "<group>"; };
F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = "<group>"; };
F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = "<group>"; };
F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = "<group>"; };
F96D3E2808F272A5004A47F5 /* DictObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DictObj.3; sourceTree = "<group>"; };
F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoOneEvent.3; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
| < < < < < < < | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D444208F272B9004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = "<group>"; };
F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
| < | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 |
F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = "<group>"; };
F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
F96D448108F272BA004A47F5 /* tcl.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tcl.m4; sourceTree = "<group>"; };
F96D448208F272BA004A47F5 /* tcl.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.rc; sourceTree = "<group>"; };
F96D448308F272BA004A47F5 /* tclAppInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAppInit.c; sourceTree = "<group>"; };
F96D448408F272BA004A47F5 /* tclConfig.sh.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tclConfig.sh.in; sourceTree = "<group>"; };
F96D448608F272BA004A47F5 /* tclsh.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tclsh.rc; sourceTree = "<group>"; };
F96D448708F272BA004A47F5 /* tclWin32Dll.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWin32Dll.c; sourceTree = "<group>"; };
F96D448808F272BA004A47F5 /* tclWinChan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinChan.c; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, F96D3E2708F272A5004A47F5 /* dict.n */, F96D3E2808F272A5004A47F5 /* DictObj.3 */, |
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 | F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */, F96D43D208F272B8004A47F5 /* configure */, F96D43D308F272B8004A47F5 /* configure.ac */, F96D442508F272B8004A47F5 /* genStubs.tcl */, F96D442708F272B8004A47F5 /* index.tcl */, F96D442808F272B8004A47F5 /* installData.tcl */, F96D442908F272B8004A47F5 /* loadICU.tcl */, | < < < < < < < < | 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 | F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */, F96D43D208F272B8004A47F5 /* configure */, F96D43D308F272B8004A47F5 /* configure.ac */, F96D442508F272B8004A47F5 /* genStubs.tcl */, F96D442708F272B8004A47F5 /* index.tcl */, F96D442808F272B8004A47F5 /* installData.tcl */, F96D442908F272B8004A47F5 /* loadICU.tcl */, F96D442B08F272B8004A47F5 /* makeTestCases.tcl */, F96D443208F272B8004A47F5 /* README */, F96D443308F272B8004A47F5 /* regexpTestLib.tcl */, F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */, F96D443A08F272B9004A47F5 /* tclZIC.tcl */, F92D7F100DE777240033A13A /* tsdPerf.tcl */, F96D443B08F272B9004A47F5 /* uniClass.tcl */, F96D443C08F272B9004A47F5 /* uniParse.tcl */, ); path = tools; |
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 | F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, F96D447D08F272BA004A47F5 /* stub16.c */, F96D447E08F272BA004A47F5 /* tcl.dsp */, F96D447F08F272BA004A47F5 /* tcl.dsw */, | < | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 | F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, F96D447D08F272BA004A47F5 /* stub16.c */, F96D447E08F272BA004A47F5 /* tcl.dsp */, F96D447F08F272BA004A47F5 /* tcl.dsw */, F96D448108F272BA004A47F5 /* tcl.m4 */, F96D448208F272BA004A47F5 /* tcl.rc */, F96D448308F272BA004A47F5 /* tclAppInit.c */, F96D448408F272BA004A47F5 /* tclConfig.sh.in */, F96D448608F272BA004A47F5 /* tclsh.rc */, F96D448708F272BA004A47F5 /* tclWin32Dll.c */, F96D448808F272BA004A47F5 /* tclWinChan.c */, |
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 | inputPaths = ( ); name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; | | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 |
inputPaths = (
);
name = "Run Testsuite";
outputPaths = (
);
runOnlyForDeploymentPostprocessing = 0;
shellPath = /bin/bash;
shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi";
showEnvVarsInLog = 0;
};
F97AF02F0B665DA900310EA2 /* Build Tcl */ = {
isa = PBXShellScriptBuildPhase;
buildActionMask = 2147483647;
files = (
);
|
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = "<group>"; };
F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = "<group>"; };
F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = "<group>"; };
F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = "<group>"; };
F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = "<group>"; };
F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = "<group>"; };
F96D3E2808F272A5004A47F5 /* DictObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DictObj.3; sourceTree = "<group>"; };
F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoOneEvent.3; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
| < < < < < < < | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D444208F272B9004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = "<group>"; };
F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
| < | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 |
F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = "<group>"; };
F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
F96D448108F272BA004A47F5 /* tcl.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tcl.m4; sourceTree = "<group>"; };
F96D448208F272BA004A47F5 /* tcl.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.rc; sourceTree = "<group>"; };
F96D448308F272BA004A47F5 /* tclAppInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAppInit.c; sourceTree = "<group>"; };
F96D448408F272BA004A47F5 /* tclConfig.sh.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tclConfig.sh.in; sourceTree = "<group>"; };
F96D448608F272BA004A47F5 /* tclsh.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tclsh.rc; sourceTree = "<group>"; };
F96D448708F272BA004A47F5 /* tclWin32Dll.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWin32Dll.c; sourceTree = "<group>"; };
F96D448808F272BA004A47F5 /* tclWinChan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinChan.c; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 | F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */, F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */, F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */, F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */, F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */, F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */, F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */, F96D3E2208F272A5004A47F5 /* CrtAlias.3 */, F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */, F96D3E2408F272A5004A47F5 /* CrtTrace.3 */, F96D3E2508F272A5004A47F5 /* dde.n */, F93599D30DF1F8F500E04F67 /* define.n */, F96D3E2608F272A5004A47F5 /* DetachPids.3 */, F96D3E2708F272A5004A47F5 /* dict.n */, F96D3E2808F272A5004A47F5 /* DictObj.3 */, |
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 |
path = tests;
sourceTree = "<group>";
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
| < < < < < < < < < < | 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
path = tests;
sourceTree = "<group>";
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
F96D442908F272B8004A47F5 /* loadICU.tcl */,
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */,
F96D443208F272B8004A47F5 /* README */,
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */,
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */,
F96D443A08F272B9004A47F5 /* tclZIC.tcl */,
F92D7F100DE777240033A13A /* tsdPerf.tcl */,
F96D443B08F272B9004A47F5 /* uniClass.tcl */,
F96D443C08F272B9004A47F5 /* uniParse.tcl */,
);
path = tools;
|
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 | F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, F96D447D08F272BA004A47F5 /* stub16.c */, F96D447E08F272BA004A47F5 /* tcl.dsp */, F96D447F08F272BA004A47F5 /* tcl.dsw */, | < | 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 | F96D447808F272BA004A47F5 /* makefile.vc */, F96D447908F272BA004A47F5 /* nmakehlp.c */, F96D447A08F272BA004A47F5 /* README */, F96D447C08F272BA004A47F5 /* rules.vc */, F96D447D08F272BA004A47F5 /* stub16.c */, F96D447E08F272BA004A47F5 /* tcl.dsp */, F96D447F08F272BA004A47F5 /* tcl.dsw */, F96D448108F272BA004A47F5 /* tcl.m4 */, F96D448208F272BA004A47F5 /* tcl.rc */, F96D448308F272BA004A47F5 /* tclAppInit.c */, F96D448408F272BA004A47F5 /* tclConfig.sh.in */, F96D448608F272BA004A47F5 /* tclsh.rc */, F96D448708F272BA004A47F5 /* tclWin32Dll.c */, F96D448808F272BA004A47F5 /* tclWinChan.c */, |
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 | inputPaths = ( ); name = "Run Testsuite"; outputPaths = ( ); runOnlyForDeploymentPostprocessing = 0; shellPath = /bin/bash; | | | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 |
inputPaths = (
);
name = "Run Testsuite";
outputPaths = (
);
runOnlyForDeploymentPostprocessing = 0;
shellPath = /bin/bash;
shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi";
showEnvVarsInLog = 0;
};
F97AF02F0B665DA900310EA2 /* Build Tcl */ = {
isa = PBXShellScriptBuildPhase;
buildActionMask = 2147483647;
files = (
);
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXBundle.c.
1 2 3 4 5 6 | /* * tclMacOSXBundle.c -- * * This file implements functions that inspect CFBundle structures on * MacOS X. * | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | /* * tclMacOSXBundle.c -- * * This file implements functions that inspect CFBundle structures on * MacOS X. * * Copyright © 2001-2009 Apple Inc. * Copyright © 2003-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" #include "tclInt.h" #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #ifndef TCL_DYLD_USE_DLFCN /* * Use preferred dlfcn API on 10.4 and later |
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
if (!initialized) {
#if TCL_DYLD_USE_DLFCN
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
if (tclMacOSXDarwinRelease >= 8)
#endif
{
| | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
if (!initialized) {
#if TCL_DYLD_USE_DLFCN
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
if (tclMacOSXDarwinRelease >= 8)
#endif
{
openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT,
"CFBundleOpenBundleResourceMap");
#ifdef TCL_DEBUG_LOAD
if (!openresourcemap) {
const char *errMsg = dlerror();
TclLoadDbgMsg("dlsym() failed: %s", errMsg);
}
|
| ︙ | ︙ | |||
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 |
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL,
hasResourceFile, maxPathLen, libraryPath);
}
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenVersionedBundleResources --
*
* Given the bundle and version name for a shared library (version name
| > > > | 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 |
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
#undef Tcl_MacOSXOpenBundleResources
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL,
hasResourceFile, maxPathLen, libraryPath);
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenVersionedBundleResources --
*
* Given the bundle and version name for a shared library (version name
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 | * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ int Tcl_MacOSXOpenVersionedBundleResources( | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenVersionedBundleResources(
TCL_UNUSED(Tcl_Interp *),
const char *bundleName,
const char *bundleVersion,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
1 2 3 4 5 6 | /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. * * Copyright © 2003-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
| | | | | 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 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
}
switch (objIndex) {
case MACOSX_CREATOR_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->creator));
break;
case MACOSX_TYPE_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
TclNewIntObj(*attributePtrPtr,
(finder->fdFlags & kFinfoIsInvisible) != 0);
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
TclNewIntObj(*attributePtrPtr, *rsrcForkSize);
break;
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", -1));
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
1 2 3 4 5 6 7 | /* * tclMacOSXNotify.c -- * * This file contains the implementation of a merged CFRunLoop/select() * based notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.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 | /* * tclMacOSXNotify.c -- * * This file contains the implementation of a merged CFRunLoop/select() * based notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2001-2009, Apple Inc. * Copyright © 2005-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * 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> #undef TCL_MAC_DEBUG_NOTIFIER #endif #ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is * in tclUnixNotfy.c */ #include <CoreFoundation/CoreFoundation.h> #include <pthread.h> /* #define TCL_MAC_DEBUG_NOTIFIER 1 */ #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 * most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 |
return _spin_lock_try(lock);
}
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
/*
| > | > > > > > | > > > > > > > > > > > > > | | 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 |
return _spin_lock_try(lock);
}
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
#endif /* not using os_unfair_lock */
/*
* These locks control access to the global notifier state.
*/
#if defined(USE_OS_UNFAIR_LOCK)
static os_unfair_lock notifierInitLock = OS_UNFAIR_LOCK_INIT;
static os_unfair_lock notifierLock = OS_UNFAIR_LOCK_INIT;
#else
static OSSpinLock notifierInitLock = SPINLOCK_INIT;
static OSSpinLock notifierLock = SPINLOCK_INIT;
#endif
/*
* Macros that abstract notifier locking/unlocking
*/
#if defined(USE_OS_UNFAIR_LOCK)
#define LOCK_NOTIFIER_INIT os_unfair_lock_lock(¬ifierInitLock)
#define UNLOCK_NOTIFIER_INIT os_unfair_lock_unlock(¬ifierInitLock)
#define LOCK_NOTIFIER os_unfair_lock_lock(¬ifierLock)
#define UNLOCK_NOTIFIER os_unfair_lock_unlock(¬ifierLock)
#define LOCK_NOTIFIER_TSD os_unfair_lock_lock(&tsdPtr->tsdLock)
#define UNLOCK_NOTIFIER_TSD os_unfair_lock_unlock(&tsdPtr->tsdLock)
#else
#define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock)
#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
/*
* The debug version of the Notifier only works if using OSSpinLock.
*/
#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK)
#define TclMacOSXNotifierDbgMsg(m, ...) \
do { \
fprintf(notifierLog?notifierLog:stderr, "tclMacOSXNotify.c:%d: " \
"%s() pid %5d thread %10p: " m "\n", __LINE__, __func__, \
getpid(), pthread_self(), ##__VA_ARGS__); \
fflush(notifierLog?notifierLog:stderr); \
} while (0)
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
#p, TclpWideClicksToNanoseconds(e-s)); \
}
#undef LOCK_NOTIFIER_INIT
#define LOCK_NOTIFIER_INIT SpinLockLockDbg(¬ifierInitLock)
#undef LOCK_NOTIFIER
#define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock)
#undef LOCK_NOTIFIER_TSD
| | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
#p, TclpWideClicksToNanoseconds(e-s)); \
}
#undef LOCK_NOTIFIER_INIT
#define LOCK_NOTIFIER_INIT SpinLockLockDbg(¬ifierInitLock)
#undef LOCK_NOTIFIER
#define LOCK_NOTIFIER SpinLockLockDbg(¬ifierLock)
#undef LOCK_NOTIFIER_TSD
#define LOCK_NOTIFIER_TSD SpinLockLockDbg(tsdPtr->tsdLock)
#include <asl.h>
static FILE *notifierLog = NULL;
#ifndef NOTIFIER_LOG
#define NOTIFIER_LOG "/tmp/tclMacOSXNotify.log"
#endif
#define OPEN_NOTIFIER_LOG \
if (!notifierLog) { \
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
* this thread. */
int sleeping; /* True if runloop is inside Tcl_Sleep. */
int runLoopSourcePerformed; /* True after the runLoopSource callack was
* performed. */
int runLoopRunning; /* True if this thread's Tcl runLoop is
* running. */
int runLoopNestingLevel; /* Level of nested runLoop invocations. */
| < < > > > > > | 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 |
* this thread. */
int sleeping; /* True if runloop is inside Tcl_Sleep. */
int runLoopSourcePerformed; /* True after the runLoopSource callack was
* performed. */
int runLoopRunning; /* True if this thread's Tcl runLoop is
* running. */
int runLoopNestingLevel; /* Level of nested runLoop invocations. */
/* Must hold the notifierLock before accessing the following fields: */
/* Start notifierLock section */
int onList; /* True if this thread is on the
* waitingList */
struct ThreadSpecificData *nextPtr, *prevPtr;
/* All threads that are currently waiting on
* an event have their ThreadSpecificData
* structure on a doubly-linked listed formed
* from these pointers. */
/* End notifierLock section */
#if defined(USE_OS_UNFAIR_LOCK)
os_unfair_lock tsdLock;
#else
OSSpinLock tsdLock; /* Must hold this lock before acessing the
* following fields from more than one
* thread. */
#endif
/* Start tsdLock section */
SelectMasks checkMasks; /* This structure is used to build up the
* masks to be used in the next call to
* select. Bits are set in response to calls
* to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
| < | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) {
Tcl_Panic("Tcl_InitNotifier: pthread_once failed");
}
#endif
#ifndef __CONSTANT_CFSTRINGS__
if (!tclEventsOnlyRunLoopMode) {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 | } CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes); CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode); bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext)); runLoopObserverContext.info = tsdPtr; runLoopObserver = CFRunLoopObserverCreate(NULL, | | | > > > > | 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 |
}
CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes);
CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode);
bzero(&runLoopObserverContext, sizeof(CFRunLoopObserverContext));
runLoopObserverContext.info = tsdPtr;
runLoopObserver = CFRunLoopObserverCreate(NULL,
kCFRunLoopEntry|kCFRunLoopExit, TRUE,
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserver) {
Tcl_Panic("Tcl_InitNotifier: could not create "
"CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserver, kCFRunLoopCommonModes);
/*
* Create a second CFRunLoopObserver with the same callback as above
* for the tclEventsOnlyRunLoopMode to ensure that the callback can be
* re-entered via Tcl_ServiceAll() in the kCFRunLoopBeforeWaiting case
* (CFRunLoop prevents observer callback re-entry of a given observer
* instance).
*/
runLoopObserverTcl = CFRunLoopObserverCreate(NULL,
kCFRunLoopEntry|kCFRunLoopExit, TRUE,
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserverTcl) {
Tcl_Panic("Tcl_InitNotifier: could not create "
"CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserverTcl,
tclEventsOnlyRunLoopMode);
tsdPtr->runLoop = runLoop;
tsdPtr->runLoopSource = runLoopSource;
tsdPtr->runLoopObserver = runLoopObserver;
tsdPtr->runLoopObserverTcl = runLoopObserverTcl;
tsdPtr->runLoopTimer = NULL;
tsdPtr->waitTime = CF_TIMEINTERVAL_FOREVER;
#if defined(USE_OS_UNFAIR_LOCK)
tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
#else
tsdPtr->tsdLock = SPINLOCK_INIT;
#endif
}
LOCK_NOTIFIER_INIT;
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
notifierThreadRunning = 0;
OPEN_NOTIFIER_LOG;
}
ENABLE_ASL;
notifierCount++;
UNLOCK_NOTIFIER_INIT;
| < | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
notifierThreadRunning = 0;
OPEN_NOTIFIER_LOG;
}
ENABLE_ASL;
notifierCount++;
UNLOCK_NOTIFIER_INIT;
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclMacOSXNotifierAddRunLoopMode --
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
ThreadSpecificData *tsdPtr;
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
}
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 |
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
ClientData clientData)
{
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
ClientData clientData)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
}
LOCK_NOTIFIER_TSD;
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 | * None. * *---------------------------------------------------------------------- */ static void TimerWakeUp( | | | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
* None.
*
*----------------------------------------------------------------------
*/
static void
TimerWakeUp(
TCL_UNUSED(CFRunLoopTimerRef),
TCL_UNUSED(ClientData))
{
}
/*
*----------------------------------------------------------------------
*
* Tcl_ServiceModeHook --
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
waitTime = CF_TIMEINTERVAL_FOREVER;
tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->runLoop) {
Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
}
if (timePtr) {
Tcl_Time vTime = *timePtr;
/*
* TIP #233 (Virtualized Time). Is virtual time in effect? And do we
* actually have something to scale? If yes to both then we call the
* handler to do this scaling.
*/
if (vTime.sec != 0 || vTime.usec != 0) {
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
/*
| > > > > > < | > > > > | < > > > > > > | | | | | | | | | 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 |
waitTime = CF_TIMEINTERVAL_FOREVER;
tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->runLoop) {
Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
}
/*
* A NULL timePtr means wait forever.
*/
if (timePtr) {
Tcl_Time vTime = *timePtr;
/*
* TIP #233 (Virtualized Time). Is virtual time in effect? And do we
* actually have something to scale? If yes to both then we call the
* handler to do this scaling.
*/
if (vTime.sec != 0 || vTime.usec != 0) {
tclScaleTimeProcPtr(&vTime, tclTimeClientData);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
/*
* The max block time was set to 0.
*
* If we set the waitTime to 0, then the call to CFRunLoopInMode
* may return without processing all of its sources. The Apple
* documentation says that if the waitTime is 0 "only one pass is
* made through the run loop before returning; if multiple sources
* or timers are ready to fire immediately, only one (possibly two
* if one is a version 0 source) will be fired, regardless of the
* value of returnAfterSourceHandled." This can cause some chanio
* tests to fail. So we use a small positive waitTime unless there
* is another RunLoop running.
*/
polling = 1;
waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001;
}
}
StartNotifierThread();
LOCK_NOTIFIER_TSD;
tsdPtr->polling = polling;
UNLOCK_NOTIFIER_TSD;
tsdPtr->runLoopSourcePerformed = 0;
/*
* If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was
* called recursively) start a new runloop in a custom runloop mode
* containing only the source for the notifier thread. Otherwise wakeups
* from other sources added to the common runloop mode might get lost or
* 3rd party event handlers might get called when they do not expect to
* be.
*/
runLoopRunning = tsdPtr->runLoopRunning;
tsdPtr->runLoopRunning = 1;
runLoopStatus = CFRunLoopRunInMode(
runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode,
waitTime, TRUE);
tsdPtr->runLoopRunning = runLoopRunning;
LOCK_NOTIFIER_TSD;
tsdPtr->polling = 0;
UNLOCK_NOTIFIER_TSD;
switch (runLoopStatus) {
case kCFRunLoopRunFinished:
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
static void
QueueFileEvents(
void *info)
{
SelectMasks readyMasks;
FileHandler *filePtr;
| | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
static void
QueueFileEvents(
void *info)
{
SelectMasks readyMasks;
FileHandler *filePtr;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
/*
* Queue all detected file events.
*/
LOCK_NOTIFIER_TSD;
FD_COPY(&tsdPtr->readyMasks.readable, &readyMasks.readable);
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 | * None. * *---------------------------------------------------------------------- */ static void UpdateWaitingListAndServiceEvents( | | | < | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
* None.
*
*----------------------------------------------------------------------
*/
static void
UpdateWaitingListAndServiceEvents(
TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
if (tsdPtr->sleeping) {
return;
}
switch (activity) {
case kCFRunLoopEntry:
tsdPtr->runLoopNestingLevel++;
if (tsdPtr->numFdBits > 0 || tsdPtr->polling) {
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
case kCFRunLoopExit:
if (tsdPtr->runLoopNestingLevel == 1) {
LOCK_NOTIFIER;
OnOffWaitingList(tsdPtr, 0, 1);
UNLOCK_NOTIFIER;
}
tsdPtr->runLoopNestingLevel--;
| < < < < < < < < < < < < < | 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
case kCFRunLoopExit:
if (tsdPtr->runLoopNestingLevel == 1) {
LOCK_NOTIFIER;
OnOffWaitingList(tsdPtr, 0, 1);
UNLOCK_NOTIFIER;
}
tsdPtr->runLoopNestingLevel--;
break;
default:
break;
}
}
/*
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
| | | 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 |
OnOffWaitingList(
ThreadSpecificData *tsdPtr,
int onList,
int signalNotifier)
{
int changeWaitingList;
#if defined(TCL_MAC_DEBUG_NOTIFIER) && !defined(USE_OS_UNFAIR_LOCK)
if (SpinLockTry(¬ifierLock)) {
Tcl_Panic("OnOffWaitingList: notifierLock unlocked");
}
#endif
changeWaitingList = (!onList ^ !tsdPtr->onList);
if (changeWaitingList) {
if (onList) {
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 | * the notifier thread first starts. * *---------------------------------------------------------------------- */ static TCL_NORETURN void NotifierThreadProc( | | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 |
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask, writableMask, exceptionalMask;
int i, numFdBits = 0, polling;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 |
*/
static void
AtForkChild(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| > > > > > > > > > | | | > | 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 |
*/
static void
AtForkChild(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If a child process unlocks an os_unfair_lock that was created in its parent
* the child will exit with an illegal instruction error. So we reinitialize
* the lock in the child rather than attempt to unlock it.
*/
#if defined(USE_OS_UNFAIR_LOCK)
tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
#else
UNLOCK_NOTIFIER_TSD;
UNLOCK_NOTIFIER;
UNLOCK_NOTIFIER_INIT;
#endif
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
if (!noCFafterFork) {
CFRunLoopSourceInvalidate(tsdPtr->runLoopSource);
CFRelease(tsdPtr->runLoopSource);
if (tsdPtr->runLoopTimer) {
CFRunLoopTimerInvalidate(tsdPtr->runLoopTimer);
|
| ︙ | ︙ |
Changes to pkgs/README.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | All files of the package need to be contained in (subdirs of ...) a single subdirectory of the "pkgs" directrory. In that subdirectory of "pkgs" there must be an executable file named "configure". When the program "configure" is run, it should generate a file "Makefile" in the current working directory. The "configure" program should be able to accept as command line arguments all the | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
All files of the package need to be contained in (subdirs of ...) a
single subdirectory of the "pkgs" directrory.
In that subdirectory of "pkgs" there must be an executable file named
"configure". When the program "configure" is run, it should generate
a file "Makefile" in the current working directory. The "configure"
program should be able to accept as command line arguments all the
arguments that can be passed to the top unix/configure program. It
should also accept the --with-tcl= and --with-tclinclude= options in
the conventional way.
The generated "Makefile" must be one suitable for controlling the operations
of a `make` program. The following targets must be defined:
<default>: Perform a build of the runtime components of the
|
| ︙ | ︙ |
Changes to tests-perf/clock.perf.tcl.
1 2 3 4 5 6 7 8 9 10 11 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # test-performance.tcl -- # # This file provides common performance tests for comparison of tcl-speed # degradation by switching between branches. # (currently for clock ensemble only) # # ------------------------------------------------------------------------ # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation by switching between branches.
# (currently for clock ensemble only)
#
# ------------------------------------------------------------------------
#
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
array set in {-time 500}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
|
| ︙ | ︙ |
Changes to tests-perf/test-performance.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # ------------------------------------------------------------------------ # # test-performance.tcl -- # # This file provides common performance tests for comparison of tcl-speed # degradation or regression by switching between branches. # # To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl". # # ------------------------------------------------------------------------ # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation or regression by switching between branches.
#
# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
#
# ------------------------------------------------------------------------
#
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
namespace eval ::tclTestPerf {
# warm-up interpeter compiler env, calibrate timerate measurement functionality:
|
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
| | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
set mintm 0x7FFFFFFF
set maxtm 0
set nettm 0
set wtm 0
set wcnt 0
set i 0
foreach tm $_(itm) {
if {[llength $tm] > 6} {
|
| ︙ | ︙ |
Changes to tests-perf/timer-event.perf.tcl.
1 2 3 4 5 6 7 8 9 10 11 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # timer-event.perf.tcl -- # # This file provides performance tests for comparison of tcl-speed # of timer events (event-driven tcl-handling). # # ------------------------------------------------------------------------ # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# timer-event.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of timer events (event-driven tcl-handling).
#
# ------------------------------------------------------------------------
#
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
if {![namespace exists ::tclTestPerf]} {
|
| ︙ | ︙ |
Changes to tests/aaa_exit.test.
1 2 3 4 5 6 | # Commands covered: exit, emphasis on finalization hangs # # 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 |
# Commands covered: exit, emphasis on finalization hangs
#
# 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-1997 Sun Microsystems, Inc.
# 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.
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}
|
| ︙ | ︙ |
Changes to tests/all.tcl.
1 2 3 | # all.tcl -- # # This file contains a top-level script to run all of the Tcl | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all.tcl" when running tcltest
# in this directory.
#
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2000 Ajuba Solutions
#
# 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 {*}$argv -testdir [file dirname [file dirname [file normalize [
info script]/...]]]
if {[singleProcess]} {
|
| ︙ | ︙ |
Changes to tests/append.test.
1 2 3 4 5 6 | # Commands covered: append lappend # # 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 41 42 |
# Commands covered: append lappend
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain x
test append-1.1 {append command} {
unset -nocomplain x
list [append x 1 2 abc "long string"] $x
} {{12abclong string} {12abclong string}}
test append-1.2 {append command} {
set x ""
list [append x first] [append x second] [append x third] $x
} {first firstsecond firstsecondthird firstsecondthird}
test append-1.3 {append command} {
set x "abcd"
append x
} abcd
test append-2.1 {long appends} {
set x ""
for {set i 0} {$i < 1000} {incr i} {
append x "foobar "
}
set y "foobar"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y "
expr {$x == $y}
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 |
test append-5.1 {long lappends} -setup {
unset -nocomplain x
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
| | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
test append-5.1 {long lappends} -setup {
unset -nocomplain x
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {incr i} {
set j [lindex $var $i]
if {$j ne "item $i"} {
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
|
| ︙ | ︙ |
Changes to tests/appendComp.test.
1 2 3 4 5 6 | # Commands covered: append lappend # # 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 |
# Commands covered: append lappend
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset x}
test appendComp-1.1 {append command} -setup {
unset -nocomplain x
} -body {
|
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
}
foo
} abcd
test appendComp-2.1 {long appends} {
proc foo {} {
set x ""
| | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
}
foo
} abcd
test appendComp-2.1 {long appends} {
proc foo {} {
set x ""
for {set i 0} {$i < 1000} {incr i} {
append x "foobar "
}
set y "foobar"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y"
set y "$y $y $y $y $y $y $y $y $y $y "
expr {$x == $y}
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
} -body {
set x ""
| | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
return "element $i should have been \"item $i\", was \"$j\""
}
}
return ok
}
} -body {
set x ""
for {set i 0} {$i < 300} {incr i} {
lappend x "item $i"
}
check $x 300
} -cleanup {
unset -nocomplain x
catch {rename check ""}
} -result ok
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
append myvar a
info exists ::result
}
bar
} -result {0}
test appendComp-8.1 {defer error to runtime} -setup {
| | | | | 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 |
append myvar a
info exists ::result
}
bar
} -result {0}
test appendComp-8.1 {defer error to runtime} -setup {
interp create child
} -body {
child eval {
proc foo {} {
proc append args {}
append
}
foo
}
} -cleanup {
interp delete child
} -result {}
# New tests for bug 3057639 to show off the more consistent behaviour of
# lappend in both direct-eval and bytecompiled code paths (see append.test for
# the direct-eval variants). lappend now behaves like append. 9.0/1 lappend -
# 9.2/3 append.
|
| ︙ | ︙ |
Changes to tests/apply.test.
1 2 3 4 5 6 | # Commands covered: apply # # 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 |
# Commands covered: apply
#
# 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.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2005-2006 Miguel Sofer
#
# 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::*
}
if {[info commands ::apply] eq {}} {
return
}
testConstraint memory [llength [info commands memory]]
# Tests for wrong number of arguments
test apply-1.1 {not enough arguments} -returnCodes error -body {
apply
} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
# Tests for malformed lambda
test apply-2.0 {malformed lambda} -returnCodes error -body {
set lambda a
|
| ︙ | ︙ |
Changes to tests/assemble.test.
1 2 3 4 | # assemble.test -- # # Test suite for the 'tcl::unsupported::assemble' command # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # assemble.test -- # # Test suite for the 'tcl::unsupported::assemble' command # # Copyright © 2010 Ozgur Dogan Ugurlu. # Copyright © 2010 Kevin B. Kenny. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. #----------------------------------------------------------------------------- # Commands covered: assemble |
| ︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 |
}
-result 8
-cleanup {rename x {}}
}
# assemble-15 - listIndexImm
| | < | < | < < < | < | < | < < < | < | | > | < < | < | < < < | < | < | < | < | < | < | < | < | < | < | | | | | 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 |
}
-result 8
-cleanup {rename x {}}
}
# assemble-15 - listIndexImm
test assemble-15.1 {listIndexImm - wrong # args} -body {
assemble {listIndexImm}
} -returnCodes error -match glob -result {wrong # args*}
test assemble-15.2 {listIndexImm - wrong # args} -body {
assemble {listIndexImm too many}
} -returnCodes error -match glob -result {wrong # args*}
test assemble-15.3 {listIndexImm - bad substitution} -body {
list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode
} -cleanup {
unset result
} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
test assemble-15.4 {listIndexImm - invalid index} -body {
assemble {listIndexImm rubbish}
} -returnCodes error -match glob -result {bad index "rubbish"*}
test assemble-15.5 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm 2}
} -result c
test assemble-15.6 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end-1}
} -result b
test assemble-15.7 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end}
} -result c
test assemble-15.8 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end+2}
} -result {}
test assemble-15.9 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm -1-1}
} -result {}
# assemble-16 - invokeStk
test assemble-16.1 {invokeStk - wrong # args} {
-body {
assemble {invokeStk}
}
|
| ︙ | ︙ |
Changes to tests/assocd.test.
1 2 3 4 5 6 | # This file tests the AssocData facility of Tcl # # 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 |
# This file tests the AssocData facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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.
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 testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
|
| ︙ | ︙ |
Changes to tests/async.test.
1 2 3 4 5 6 | # Commands covered: none # # This file contains a collection of tests for Tcl_AsyncCreate and related # library procedures. 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# 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.
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 testasync [llength [info commands testasync]]
testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
|
| ︙ | ︙ |
Added tests/auto-files.zip.
cannot compute difference between binary files
Added tests/auto0/auto1/file1.tcl.
> > > | 1 2 3 |
proc report1 {args} {
return ok1
}
|
Added tests/auto0/auto1/package1.tcl.
> > > > > | 1 2 3 4 5 |
proc HeresPackage1 {args} {
return OK1
}
package provide SafeTestPackage1 1.2.3
|
Added tests/auto0/auto1/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" 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. package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] |
Added tests/auto0/auto1/tclIndex.
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | # 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(report1) [list source [file join $dir file1.tcl]] |
Added tests/auto0/auto2/file2.tcl.
> > > | 1 2 3 |
proc report2 {args} {
return ok2
}
|
Added tests/auto0/auto2/package2.tcl.
> > > > > | 1 2 3 4 5 |
proc HeresPackage2 {args} {
return OK2
}
package provide SafeTestPackage2 2.3.4
|
Added tests/auto0/auto2/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" 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. package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] |
Added tests/auto0/auto2/tclIndex.
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | # 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(report2) [list source [file join $dir file2.tcl]] |
Added tests/auto0/modules/mod1/test1-1.0.tm.
> > > > > | 1 2 3 4 5 |
namespace eval mod1::test1 {}
proc mod1::test1::try1 args {
return res1
}
|
Added tests/auto0/modules/mod2/test2-2.0.tm.
> > > > > | 1 2 3 4 5 |
namespace eval mod2::test2 {}
proc mod2::test2::try2 args {
return res2
}
|
Added tests/auto0/modules/test0-0.5.tm.
> > > > > | 1 2 3 4 5 |
namespace eval test0 {}
proc test0::try0 args {
return res0
}
|
Changes to tests/autoMkindex.test.
1 2 3 4 5 | # Commands covered: auto_mkindex auto_import # # This file contains tests related to autoloading and generating the # autoloading index. # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating the
# autoloading index.
#
# Copyright © 1998 Lucent Technologies, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
makeFile {# Test file for:
# auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading facility.
|
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
# proc another {args} { ... }
# }
# }
#
# Note that procedures and itcl class definitions can be nested inside of
# namespaces.
#
| | | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# proc another {args} { ... }
# }
# }
#
# Note that procedures and itcl class definitions can be nested inside of
# namespaces.
#
# Copyright © 1993-1998 Lucent Technologies, Inc.
# This shouldn't cause any problems
namespace import -force blt::*
# Should be able to handle "proc" definitions, even if they are preceded by
# white space.
proc normal {x y} {return [expr {$x+$y}]}
proc indented {x y} {return [expr {$x+$y}]}
#
# Should be able to handle proc declarations within namespaces, even if they
# have explicit namespace paths.
#
namespace eval buried {
proc inside {args} {return "inside: $args"}
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
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
| | | | | | | | | 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 |
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
# Child hook executes interesting code in the interp used to watch code.
test autoMkindex-3.1 {childHook} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::childhook {
_%@namespace eval ::blt {
proc foo {} {}
_%@namespace export foo
}
}
auto_mkindex_parser::childhook { _%@namespace import -force ::blt::* }
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} -cleanup {
# Reset initCommands to avoid trashing other tests
AutoMkindexTestReset
} -result 1
# The auto_mkindex_parser::command is used to register commands that create
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 |
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 {}
| | | | | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
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 {}
interp create child
} -body {
auto_mkindex . pkg/magicchar2.tcl
# Make a child interp to test the autoloading
child eval {lappend auto_path [pwd]}
child eval {catch {{[magic mojo proc]}}}
} -cleanup {
interp delete child
removeFile [file join pkg magicchar2.tcl]
removeDirectory pkg
} -result 0
# Clean up.
unset result
|
| ︙ | ︙ |
Changes to tests/basic.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains tests for the tclBasic.c source file. Tests appear in # the same order as the C code that they test. The set of tests is # currently incomplete since it currently includes only new tests for # code changed for the addition of Tcl namespaces. Other variable- # related tests appear in several other test files including # assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, # and trace.test. # # 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 |
# This file contains tests for the tclBasic.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
# and trace.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
catch {namespace delete test_ns_basic}
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
proc l3 {} {
list i j k {l l}
}
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
| | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
proc l3 {} {
list i j k {l l}
}
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
if {$noComp} {
interp alias {} run {} testevalex
set constraints testevalex
} else {
interp alias {} run {} if 1
set constraints {}
}
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
| | | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 |
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
interp create child
interp alias {} foo child return
} -body {
list [catch foo m] $m
} -cleanup {
unset -nocomplain m
interp delete child
} -result {0 {}}
# Clean up after expand tests
unset noComp l1 l2 constraints
rename l3 {}
rename run {}
|
| ︙ | ︙ |
Changes to tests/binary.test.
1 2 3 4 5 6 | # This file tests the tclBinary.c file and the "binary" Tcl command. # # 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 |
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# 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 © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 |
list [binary scan "abc def \x00 " A* arg1] $arg1
} -result {1 {abc def}}
test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -body {
list [binary scan "abc def \x00ghi " A* arg1] $arg1
} -result [list 1 "abc def \x00ghi"]
| | > > > > > > > > > | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
list [binary scan "abc def \x00 " A* arg1] $arg1
} -result {1 {abc def}}
test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -body {
list [binary scan "abc def \x00ghi " A* arg1] $arg1
} -result [list 1 "abc def \x00ghi"]
test binary-21.13 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -body {
list [binary scan "abc def \x00 " C* arg1] $arg1
} -result {1 {abc def }}
test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -body {
list [binary scan "abc def \x00ghi" C* arg1] $arg1
} -result {1 {abc def }}
test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
binary scan abc b
} -result {not enough arguments for all format specifiers}
test binary-22.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
list [binary scan \x52\x53 b* arg1] $arg1
} {1 0100101011001010}
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
| | | | 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
test binary-71.8 {binary decode hex} -match glob -body {
binary decode hex -strict "61 61"
} -returnCodes error -result {invalid hexadecimal digit " " * at position 2}
test binary-71.9 {binary decode hex} -body {
set r [binary decode hex "6"]
list [string length $r] $r
} -result {0 {}}
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
|
| ︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
| > > > | | | | | | | | 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 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-72.29 {binary encode base64} {
string length [binary encode base64 -maxlen 3 -wrapchar \xca abc]
} 5
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
test binary-73.5 {binary decode base64} -body {
binary decode base64 AAECAwQAAQID
} -result "\0\1\2\3\4\0\1\2\3"
test binary-73.6 {binary decode base64} -body {
binary decode base64 AA==
} -result "\0"
test binary-73.7 {binary decode base64} -body {
binary decode base64 AAA=
} -result "\0\0"
test binary-73.8 {binary decode base64} -body {
binary decode base64 AAAA
} -result "\0\0\0"
test binary-73.9 {binary decode base64} -body {
binary decode base64 AAAAAA==
} -result "\0\0\0\0"
test binary-73.10 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n[string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.11 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.12 {binary decode base64} -body {
binary decode base64 -strict ":YWJj"
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0}
test binary-73.13 {binary decode base64} -body {
set s "[string repeat YWJj 10]:[string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40}
test binary-73.14 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.20 {binary decode base64} -body {
set r [binary decode base64 Y]
list [string length $r] $r
|
| ︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
| | | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
list \
[string length [binary decode base64 =]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 "\r\n\t="]] \
|
| ︙ | ︙ | |||
2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
| > > > | 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-73.37 {binary decode base64: Bug ffeb2097af} {
binary decode base64 [binary encode base64 -maxlen 3 -wrapchar : abc]
} abc
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
| | > > > > > > | | | 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 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 4 abcabcabc
} -result {line length out of range}
test binary-74.12 {binary encode uuencode} -body {
binary encode uuencode -maxlen 5 -wrapchar \t abcabcabc
} -result #86)C\t#86)C\t#86)C\t
test binary-74.13 {binary encode uuencode} -body {
binary encode uuencode -maxlen 85 -wrapchar \t abcabcabc
} -result )86)C86)C86)C\t
test binary-74.14 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 86 abcabcabc
} -result {line length out of range}
test binary-75.1 {binary decode uuencode} -body {
binary decode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-75.2 {binary decode uuencode} -body {
binary decode uuencode "#86)C\n"
} -result {abc}
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
| | | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0}
test binary-75.13 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]|[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41}
test binary-75.14 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character *}
test binary-75.20 {binary decode uuencode} -body {
set r [binary decode uuencode " 8"]
list [string length $r] $r
|
| ︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
| | | 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5}
test binary-75.26 {binary decode uuencode} -body {
string length [binary decode uuencode " "]
} -result 0
test binary-76.1 {binary string appending growth algorithm} unix {
# Create zero-length byte array first
set f [open /dev/null rb]
|
| ︙ | ︙ | |||
2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 |
test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
# just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3):
binary encode hex \U0001f415
binary scan \U0001f415 a* v; set v
set str {}
} -result {}
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
# just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3):
binary encode hex \U0001f415
binary scan \U0001f415 a* v; set v
set str {}
} -result {}
testConstraint testsetbytearraylength \
[expr {"testsetbytearraylength" in [info commands]}]
test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat A B C] 1
} A
test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat \u0141 B C] 1
} A
test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring "\u4E4E"
} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)"
test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.4 {TclGetBytesFromObj} -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)"
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/case.test.
1 2 3 4 5 6 | # Commands covered: case # # 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 |
# Commands covered: case
#
# 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 Sun Microsystems, Inc.
# 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.
if {![llength [info commands case]]} {
# No "case" command? So no need to test
return
}
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test case-1.1 {simple pattern} {
case a in a {format 1} b {format 2} c {format 3} default {format 4}
} 1
test case-1.2 {simple pattern} {
|
| ︙ | ︙ |
Changes to tests/chan.test.
1 2 3 4 | # This file contains a collection of tests for the Tcl built-in 'chan' # command. 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 |
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright © 2005 Donal K. Fellows
#
# 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::*
}
#
# Note: The tests for the chan methods "create" and "postevent"
# currently reside in the file "ioCmd.test".
#
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
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
| | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
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
|
| ︙ | ︙ |
Changes to tests/chanio.test.
1 2 3 4 5 6 7 8 | # -*- tcl -*- # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # 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 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::io {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::tcltestlib [info loaded {} Tcltest]
}
package require tcltests
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testservicemode [llength [info commands testservicemode]]
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
chan puts $f hi
chan close $f
set f [open $path(test1)]
list [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 256 $a]
| | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
chan puts $f hi
chan close $f
set f [open $path(test1)]
list [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 256 $a]
test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [openpipe w+ $path(cat)]
chan puts -nonewline $f "hi\nwould"
chan flush $f
chan gets $f
chan configure $f -blocking 0
chan gets $f line
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 |
chan configure $f -translation crlf -buffersize 16
list [chan gets $f line] $line [testchannel inputbuffered $f]
} -cleanup {
chan close $f
} -result [list 15 "123456789012345" 15]
test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup {
set x ""
| | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 |
chan configure $f -translation crlf -buffersize 16
list [chan gets $f line] $line [testchannel inputbuffered $f]
} -cleanup {
chan close $f
} -result [list 15 "123456789012345" 15]
test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# (FilterInputBytes() != 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {crlf lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
|
| ︙ | ︙ | |||
845 846 847 848 849 850 851 |
lappend x [chan gets $f line] $line [chan gets $f line] $line
lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}}
test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
set x ""
| | | | | | 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 |
lappend x [chan gets $f line] $line [chan gets $f line] $line
lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}}
test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# not (*eol == '\n')
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
lappend x [chan gets $f]
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "abcd\refg\x1a"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# Tcl_ExternalToUtf()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan configure $f -encoding utf-16
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg"
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 123456789abcdef 1 4 abcd 0}
test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# memmove()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
|
| ︙ | ︙ | |||
1017 1018 1019 1020 1021 1022 1023 |
list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
variable x {}
| | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
variable x {}
} -constraints {stdio fileevent} -body {
set f [openpipe w+ $path(cat)]
chan configure $f -buffering none
chan puts -nonewline $f "foobar"
chan configure $f -blocking 0
after 500 [namespace code {
lappend x timeout
}]
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 |
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
| | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 15 "1234567890123\uff10\uff11" 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 -encoding 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]
}]
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
chan gets $f
testchannel inputbuffered $f
} -cleanup {
chan close $f
} -result 7
test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup {
variable x {}
| | | | 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 |
chan gets $f
testchannel inputbuffered $f
} -cleanup {
chan close $f
} -result 7
test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup {
variable x {}
} -constraints {stdio testchannel fileevent} -body {
# not (bufPtr->nextPtr == NULL)
set f [openpipe w+ $path(cat)]
chan configure $f -translation lf -encoding ascii -buffering none
chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
}]
chan configure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
chan configure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result {-1 {} 42 15 123456789012345 25}
test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body {
# (bytesLeft == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary}
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 |
# 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
unset a
| | | | | 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 |
# 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
unset a
test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body {
# (bufPtr->nextAdded < bufPtr->length)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary}
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
# here
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 abcdefghijklmno 1}
test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary} -buffersize 16
chan puts -nonewline $f "abcdefghijklmno\r"
chan flush $f
# here
list [chan gets $f line] $line [testchannel queuedcr $f]
} -cleanup {
chan close $f
} -result {15 abcdefghijklmno 1}
test chan-io-8.7 {PeekAhead: cleanup} -setup {
set x ""
} -constraints {stdio testchannel fileevent} -body {
# Make sure bytes are removed from buffer.
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto binary} -buffering none
chan puts -nonewline $f "abcdefghijklmno\r"
# here
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan puts -nonewline $f "\x1a"
|
| ︙ | ︙ | |||
1339 1340 1341 1342 1343 1344 1345 |
# here
chan read $f
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyz}
test chan-io-12.4 {ReadChars: split-up char} -setup {
variable x {}
| | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
# here
chan read $f
} -cleanup {
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 -encoding 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]
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 "\u672c" 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
| | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
} -result [list "123456789012345" 1 "\u672c" 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 -encoding 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)]
|
| ︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 |
chan read $f
} -cleanup {
chan close $f
} -result "abcd\ndef\nfgh"
test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
variable x {}
variable y {}
| | | | 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 |
chan read $f
} -cleanup {
chan close $f
} -result "abcd\ndef\nfgh"
test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
variable x {}
variable y {}
} -constraints {stdio testchannel fileevent} -body {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [openpipe w+ $path(cat)]
chan configure $f -blocking 0 -buffering none -translation {auto lf}
chan event $f read [namespace code {
lappend x [chan read $f] [testchannel queuedcr $f]
}]
chan puts -nonewline $f "abcdefghj\r"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
chan puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
return $x
} -cleanup {
chan close $f
} -result [list "abcdefghj\n" 1 "01234" 0]
test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body {
# (src >= srcMax)
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts -nonewline $f "abcd\r"
chan close $f
set f [open $path(test1)]
chan configure $f -translation auto
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 |
lappend result [x eval {chan configure stdin -buffering}]
lappend result [x eval {chan configure stdout -buffering}]
lappend result [x eval {chan configure stderr -buffering}]
} -cleanup {
interp delete x
} -result {line line none}
set path(test3) [makeFile {} test3]
| | | 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 |
lappend result [x eval {chan configure stdin -buffering}]
lappend result [x eval {chan configure stdout -buffering}]
lappend result [x eval {chan configure stderr -buffering}]
} -cleanup {
interp delete x
} -result {line line none}
set path(test3) [makeFile {} test3]
test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body {
set f [open $path(test1) w]
chan puts -nonewline $f {
chan close stdin
chan close stdout
chan close stderr
set f [}
chan puts $f [list open $path(test1) r]]
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
} -cleanup {
interp delete z
} -result {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test chan-io-14.8 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
| | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
} -cleanup {
interp delete z
} -result {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test chan-io-14.8 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
} -constraints stdio -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stderr
set f [}
chan puts $f [list open $path(test1) w]]
chan puts -nonewline $f {
chan puts stderr hello
|
| ︙ | ︙ | |||
1693 1694 1695 1696 1697 1698 1699 |
chan gets $f
} -cleanup {
chan close $f
} -result hello
test chan-io-14.9 {reuse of stdio special channels} -setup {
file delete $path(script)
file delete $path(test1)
| | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
chan gets $f
} -cleanup {
chan close $f
} -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
|
| ︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 |
set f [open $path(test1) w+]
list [chan configure $f -eofchar] [chan configure $f -translation]
} -cleanup {
chan close $f
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
| | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 |
set f [open $path(test1) w+]
list [chan configure $f -eofchar] [chan configure $f -translation]
} -cleanup {
chan close $f
} -result {{{} {}} {auto lf}}
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
set path(stdout) [makeFile {} stdout]
} -constraints {stdio notWinCI} -body {
set f [open $path(script) w]
chan puts -nonewline $f {
chan close stdout
set f1 [}
chan puts $f [list open $path(stdout) w]]
chan puts $f {
chan configure $f1 -buffersize 777
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
} -result {6 6 0 6}
test chan-io-26.1 {Tcl_GetChannelInstanceData} -body {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [openpipe r << exit]
pid $f
| | | 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 |
} -result {6 6 0 6}
test chan-io-26.1 {Tcl_GetChannelInstanceData} -body {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [openpipe r << exit]
pid $f
} -constraints stdio -cleanup {
chan close $f
} -match regexp -result {^\d+$}
# Test flushing. The functions tested here are FlushChannel.
test chan-io-27.1 {FlushChannel, no output buffered} -setup {
file delete $path(test1)
|
| ︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 |
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)
| | | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 |
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 -eofchar {}
while {![chan eof stdin]} {
after 20
chan puts -nonewline $f [chan read stdin 1024]
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
chan gets $f
} -cleanup {
chan close $f
} -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)
| | | 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 |
chan gets $f
} -cleanup {
chan close $f
} -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 {
# Need to not have eof char appended on chan close, because the other
# side of the pipe already chan closed, so that writing would cause an
# error "invalid file".
chan configure stdout -eofchar {}
chan configure stderr -eofchar {}
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
expr {$l eq $x ? "ok" : "{$l} != {$x}"}
} -result ok
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
file delete $path(script)
| | | 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 |
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
expr {$l eq $x ? "ok" : "{$l} != {$x}"}
} -result ok
test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup {
file delete $path(script)
} -constraints {stdio unix testchannel} -body {
set f [open $path(script) w]
chan puts $f {
chan close stdin
chan puts [testchannel open]
}
chan close $f
set f [openpipe r $path(script)]
|
| ︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 |
chan close $f1
chan close $f2
file size $path(test1)
} -result 377
test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 |
chan close $f1
chan close $f2
file size $path(test1)
} -result 377
test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 "set f1 \[[list open $path(longfile) r]]"
chan puts $f1 {
for {set x 0} {$x < 10} {incr x} {
chan puts [chan gets $f1]
}
}
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
} -cleanup {
chan close $f1
chan close $f2
} -result ok
test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 |
} -cleanup {
chan close $f1
chan close $f2
} -result ok
test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts [chan gets stdin]
chan puts [chan gets stdin]
}
chan close $f1
set y ok
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 |
set fd [open $path(test1) r]
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup {
set fd [openpipe r cat longfile]
| | | 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 |
set fd [open $path(test1) r]
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup {
set fd [openpipe r cat longfile]
} -constraints stdio -body {
chan flush $fd
} -returnCodes error -cleanup {
catch {chan close $fd}
} -match glob -result {channel "*" wasn't opened for writing}
test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup {
file delete $path(test1)
} -body {
|
| ︙ | ︙ | |||
2534 2535 2536 2537 2538 2539 2540 |
}
lappend z [file size $path(test1)]
chan close $f1
lappend z [file size $path(test1)]
} -result {4096 12288 12600}
test chan-io-29.21 {Tcl_Flush to pipe} -setup {
file delete $path(pipe)
| | | | 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 |
}
lappend z [file size $path(test1)]
chan close $f1
lappend z [file size $path(test1)]
} -result {4096 12288 12600}
test chan-io-29.21 {Tcl_Flush to pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {set x [chan read stdin 6]}
chan puts $f1 {set cnt [string length $x]}
chan puts $f1 {chan puts "read $cnt characters"}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan gets $f1
} -cleanup {
catch {chan close $f1}
} -result "read 6 characters"
test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan configure stdout -buffering full
chan puts hello
chan puts hello
chan flush stdout
chan gets stdin
|
| ︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 |
chan flush $f1
lappend x [chan gets $f1]
} -cleanup {
chan close $f1
} -result {hello hello bye}
test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup {
file delete $path(pipe)
| | | 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 |
chan flush $f1
lappend x [chan gets $f1]
} -cleanup {
chan close $f1
} -result {hello hello bye}
test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts hello
chan puts hello
chan gets stdin
chan puts bye
}
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 |
lappend x [chan read -nonewline $f2]
} -cleanup {
chan close $f2
chan close $f
} -result "{} {Line 1\nLine 2}"
test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup {
file delete $path(test3)
| | | | | 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 |
lappend x [chan read -nonewline $f2]
} -cleanup {
chan close $f2
chan close $f
} -result "{} {Line 1\nLine 2}"
test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup {
file delete $path(test3)
} -constraints {stdio fileevent} -body {
set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)]
chan puts $f "Line 1"
chan puts $f "Line 2"
chan close $f
after 100
set f [open $path(test3) r]
chan read $f
} -cleanup {
chan close $f
} -result "Line 1\nLine 2\n"
test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body {
set f [open "|[list cat -u]" r+]
chan puts $f "Line1"
chan flush $f
chan gets $f
} -cleanup {
chan close $f
} -result {Line1}
test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup {
file delete $path(pipe)
set f [open $path(pipe) w]
chan puts $f {exit}
chan close $f
} -constraints stdio -body {
set f [openpipe r+ $path(pipe)]
chan gets $f
chan puts $f output
after 50
#
# The flush below will get a SIGPIPE. This is an expected part of the test
# and indicates that the test operates correctly. If you run this test
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
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)
| | | 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 |
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)
} -constraints stdio -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}
set x [list while {![chan eof stdin]}]
set x "$x {"
chan puts $f $x
chan puts $f { chan puts -nonewline $f [chan read stdin 4096]}
|
| ︙ | ︙ | |||
2720 2721 2722 2723 2724 2725 2726 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
| | | | 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
return $result
} -result ok
test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -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}
set x [list while {![chan eof stdin]}]
set x "$x \{"
chan puts $f $x
chan puts $f { after 20}
|
| ︙ | ︙ | |||
2787 2788 2789 2790 2791 2792 2793 |
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
chan puts $s $l
}
}
| | | 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 |
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
chan puts $s $l
}
}
} -constraints {socket tempNotMac fileevent notWinCI} -body {
proc accept {s a p} {
variable x
chan event $s readable [namespace code [list readit $s]]
chan configure $s -blocking off
set x accepted
}
proc readit {s} {
|
| ︙ | ︙ | |||
3041 3042 3043 3044 3045 3046 3047 |
}
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
string length [chan read $f]
} -cleanup {
chan close $f
| | | | 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 |
}
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
string length [chan read $f]
} -cleanup {
chan close $f
} -result [expr {700*15 + 1}]
test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
chan puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
chan puts $f $line
}
chan close $f
set f [open $path(test1) r]
chan configure $f -translation crlf
string length [chan read $f]
} -cleanup {
chan close $f
} -result [expr {700*15 + 1}]
test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
chan configure $f -translation lf
chan puts $f hello\nthere\nand\rhere
chan close $f
|
| ︙ | ︙ | |||
3900 3901 3902 3903 3904 3905 3906 |
set f [open $path(test1) r]
chan configure $f -translation crlf
while {[chan gets $f line] >= 0} {
append c $line\n
}
chan close $f
string length $c
| | | | 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 |
set f [open $path(test1) r]
chan configure $f -translation crlf
while {[chan gets $f line] >= 0} {
append c $line\n
}
chan close $f
string length $c
} -result [expr {700*15 + 1}]
test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup {
file delete $path(test1)
set c ""
} -body {
set f [open $path(test1) w]
chan configure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
chan puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
chan puts $f $line
}
chan close $f
set f [open $path(test1) r]
chan configure $f -translation auto
while {[chan gets $f line] >= 0} {
append c $line\n
}
chan close $f
string length $c
} -result [expr {700*15 + 1}]
# Test Tcl_Read and buffering.
test chan-io-32.1 {Tcl_Read, channel not readable} -body {
read stdout
} -returnCodes error -result {channel "stdout" wasn't opened for reading}
test chan-io-32.2 {Tcl_Read, zero byte count} {
|
| ︙ | ︙ | |||
4001 4002 4003 4004 4005 4006 4007 |
if {$z != $l} {
set x "$z != $l"
}
set x
} ok
test chan-io-32.10 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
| | | | 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 |
if {$z != $l} {
set x "$z != $l"
}
set x
} ok
test chan-io-32.10 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan read $f1
} -cleanup {
chan close $f1
} -result "hello\n"
test chan-io-32.11 {Tcl_Read from a pipe} -setup {
file delete $path(pipe)
set x ""
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
|
| ︙ | ︙ | |||
4127 4128 4129 4130 4131 4132 4133 |
set z broken
}
chan close $f1
set z
} ok
test chan-io-33.3 {Tcl_Gets from pipe} -setup {
file delete $path(pipe)
| | | 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 |
set z broken
}
chan close $f1
set z
} ok
test chan-io-33.3 {Tcl_Gets from pipe} -setup {
file delete $path(pipe)
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan puts [chan gets stdin]}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
chan flush $f1
chan gets $f1
|
| ︙ | ︙ | |||
4337 4338 4339 4340 4341 4342 4343 |
chan seek $f1 0 current
list $c1 $r1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {44 rstuv 49}
test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup {
set pipe [openpipe]
| | | 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 |
chan seek $f1 0 current
list $c1 $r1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {44 rstuv 49}
test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup {
set pipe [openpipe]
} -constraints stdio -body {
chan seek $pipe 0 current
} -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 {
|
| ︙ | ︙ | |||
4447 4448 4449 4450 4451 4452 4453 |
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
list $c1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {10 20}
| | | | 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 |
chan seek $f1 10 start
set c1 [chan tell $f1]
chan seek $f1 10 current
list $c1 [chan tell $f1]
} -cleanup {
chan close $f1
} -result {10 20}
test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body {
set f1 [openpipe]
chan tell $f1
} -cleanup {
chan close $f1
} -result -1
test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio {
set f1 [openpipe]
chan puts $f1 {chan puts hello}
chan flush $f1
set c [chan tell $f1]
chan gets $f1
chan close $f1
set c
|
| ︙ | ︙ | |||
4555 4556 4557 4558 4559 4560 4561 |
lappend x [chan eof $f]
chan gets $f
lappend x [chan eof $f]
lappend x [chan eof $f]
} -cleanup {
chan close $f
} -result {0 0 0 0 1 1}
| | | | 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 |
lappend x [chan eof $f]
chan gets $f
lappend x [chan eof $f]
lappend x [chan eof $f]
} -cleanup {
chan close $f
} -result {0 0 0 0 1 1}
test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup {
file delete $path(pipe)
} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan gets stdin}
chan puts $f1 {chan puts hello}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan puts $f1 hello
set x [chan eof $f1]
chan flush $f1
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
chan gets $f1
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {0 0 0 1}
test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup {
file delete $path(pipe)
} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {chan gets stdin}
chan puts $f1 {chan puts hello}
chan close $f1
set f1 [openpipe r+ $path(pipe)]
|
| ︙ | ︙ | |||
4612 4613 4614 4615 4616 4617 4618 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {{} 1}
test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup {
file delete $path(pipe)
set l ""
| | | 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result {{} 1}
test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup {
file delete $path(pipe)
set l ""
} -constraints stdio -body {
set f [open $path(pipe) w]
chan puts $f {
exit
}
chan close $f
set f [openpipe r $path(pipe)]
lappend l [chan gets $f]
|
| ︙ | ︙ | |||
4797 4798 4799 4800 4801 4802 4803 |
chan close $f
} -result {21 8 1}
# Test Tcl_InputBlocked
test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup {
set x ""
| | | | 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 |
chan close $f
} -result {21 8 1}
# Test Tcl_InputBlocked
test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup {
set x ""
} -constraints stdio -body {
set f1 [openpipe]
chan puts $f1 {chan puts hello_from_pipe}
chan flush $f1
chan gets $f1
chan configure $f1 -blocking off -buffering full
chan puts $f1 {chan puts hello}
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan flush $f1
after 200
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
} -cleanup {
chan close $f1
} -result {{} 1 hello 0 {} 1}
test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup {
set x ""
} -constraints stdio -body {
set f1 [openpipe]
chan configure $f1 -buffering line
chan puts $f1 {chan puts hello_from_pipe}
lappend x [chan gets $f1]
lappend x [chan blocked $f1]
chan puts $f1 {exit}
lappend x [chan gets $f1]
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {1 0 {} {} 0 1}
test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(pipe)
set x ""
| | | 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 |
lappend x [chan eof $f1]
} -cleanup {
chan close $f1
} -result {1 0 {} {} 0 1}
test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup {
file delete $path(pipe)
set x ""
} -constraints stdio -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan gets stdin
after 100
chan puts hi
chan gets stdin
}
|
| ︙ | ︙ | |||
5188 5189 5190 5191 5192 5193 5194 |
} -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 {}
| | | 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 |
} -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 binary
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]
|
| ︙ | ︙ | |||
5329 5330 5331 5332 5333 5334 5335 |
lappend x [chan gets $f]
} -cleanup {
chan close $f
} -result {zzy abzzy}
test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix} -body {
| | | | | | 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 |
lappend x [chan gets $f]
} -cleanup {
chan close $f
} -result {zzy abzzy}
test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix} -body {
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
set x [format 0o%03o [expr {$stats(mode) & 0o777}]]
chan puts $f "line 1"
chan close $f
set f [open $path(test3) r]
lappend x [chan gets $f]
} -cleanup {
chan close $f
} -result {0o600 {line 1}}
test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix umask} -body {
# This test only works if your umask is 2, like ouster's.
chan close [open $path(test3) {WRONLY CREAT}]
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 configure $f -eofchar {}
chan puts $f xyzzy
chan close $f
|
| ︙ | ︙ | |||
5548 5549 5550 5551 5552 5553 5554 |
chan event $f writable {}
lappend result [chan event $f readable] [chan event $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
set result {}
| | | | | | 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 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 |
chan event $f writable {}
lappend result [chan event $f readable] [chan event $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
set result {}
} -constraints {stdio unixExecs fileevent} -body {
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f r "chan read f"
chan event $f2 r "chan read f2"
chan event $f3 r "chan read f3"
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f2 r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f3 r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
chan event $f r {}
lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r]
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {{} {} {} {chan read f} {chan read f2} {chan read f3} {chan read f} {} {chan read f3} {chan read f} {} {} {} {} {}}
test chan-io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 readable [namespace code {
set x [chan gets $f2]; chan event $f2 readable {}
}]
chan puts $f2 text; chan flush $f2
variable x initial
vwait [namespace which -variable x]
return $x
} -cleanup {
catch {chan close $f2}
catch {chan close $f3}
} -result {text}
test chan-io-44.2 {FileEventProc procedure: error in read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 readable {error bogus}
chan puts $f2 text; chan flush $f2
variable x initial
vwait [namespace which -variable x]
list $x [chan event $f2 readable]
} -cleanup {
interp bgerror {} $handler
catch {chan close $f2}
catch {chan close $f3}
} -result {bogus {}}
test chan-io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
chan event $f2 writable {}
}
}]
|
| ︙ | ︙ | |||
5628 5629 5630 5631 5632 5633 5634 |
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
| | | > > < > > | | 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 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 |
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -constraints {stdio unixExecs fileevent} -body {
chan event $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
list $x [chan event $f2 writable]
} -cleanup {
interp bgerror {} $handler
catch {chan close $f2}
catch {chan close $f3}
} -result {bad-write {}}
test chan-io-44.5 {FileEventProc procedure: end of file} -constraints {
stdio unixExecs fileevent
} -body {
set f4 [openpipe r $path(cat) << foo]
chan event $f4 readable [namespace code {
if {[chan gets $f4 line] < 0} {
lappend x eof
chan event $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
chan close $f4
} -result {initial foo eof}
chan close $f
makeFile "foo bar" foo
test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} {
set f [open $path(foo) r]
chan event $f readable [namespace code {
|
| ︙ | ︙ | |||
5714 5715 5716 5717 5718 5719 5720 |
lappend x [catch {chan event $f readable}] \
[catch {chan event $f2 readable}] \
[catch {chan event $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
| | > < | > | 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 |
lappend x [catch {chan event $f readable}] \
[catch {chan event $f2 readable}] \
[catch {chan event $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} {
testfevent create
set script "set f \[[list open $path(foo) r]]\n"
append script {
set x "no event"
chan event $f readable [namespace code {
set x "f triggered: [chan gets $f]"
chan event $f readable {}
}]
}
set timer [after 10 lappend x timeout]
testfevent cmd $script
vwait x
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
|
| ︙ | ︙ | |||
5914 5915 5916 5917 5918 5919 5920 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test chan-io-48.3 {testing readability conditions} -setup {
set l ""
| | | 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test chan-io-48.3 {testing readability conditions} -setup {
set l ""
} -constraints {stdio unix nonBlockFiles fileevent} -body {
set f [open $path(bar) w]
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan puts $f abcdefg
chan close $f
|
| ︙ | ︙ | |||
6368 6369 6370 6371 6372 6373 6374 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
| | > > > | | > | | < < < > > | > > > > > > < | < < < > > | > > > > > > | > | > | > > | < < < > > | > > > | > > > > > > | > | < < < > > | > > | 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 |
lappend l [chan eof $f]
} -cleanup {
chan close $f
} -result [list 7 a\rb\rc 7 {} 7 1]
test chan-io-50.1 {testing handler deletion} -setup {
file delete $path(test1)
} -constraints testchannelevent -body {
set f [open $path(test1) w]
chan close $f
set f [open $path(test1) r]
variable z not_called
set timer [after 50 lappend z timeout]
testservicemode 0
testchannelevent $f add readable [namespace code {
variable z called
testchannelevent $f delete 0
}]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
} -result called
test chan-io-50.2 {testing handler deletion with multiple handlers} -setup {
file delete $path(test1)
chan close [open $path(test1) w]
set z ""
} -constraints {testchannelevent testservicemode} -body {
proc delhandler {f i} {
variable z
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
set z ""
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
vwait z
after cancel $timer
string equal $z \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
} -cleanup {
chan close $f
} -result 1
test chan-io-50.3 {testing handler deletion with multiple handlers} -setup {
file delete $path(test1)
chan close [open $path(test1) w]
} -constraints {testchannelevent testservicemode} -body {
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $f $i called"
testchannelevent $f delete 0
lappend z "delhandler $f $i deleted myself"
}
set z ""
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
vwait z
after cancel $timer
string equal $z \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} -cleanup {
chan close $f
} -result 1
test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
} -constraints testchannelevent -body {
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code {
if {$u eq "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}]
variable u toplevel
variable z ""
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
update
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
update
} -constraints {testchannelevent testservicemode notOSX} -body {
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {$u eq "recursive"} {
testchannelevent $f delete 1
testchannelevent $f delete 0
lappend z "del deleted notcalled"
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
set timer [after 50 lappend z timeout]
set mode [testservicemode 1]
vwait z
after cancel $timer
testservicemode $mode
lappend z "del after update"
}
}
set z ""
set u toplevel
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
update
} -result [list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup {
file delete $path(test1)
set f [open $path(test1) w]
chan close $f
} -constraints {testchannelevent testservicemode} -body {
proc first {f} {
variable u
variable z
if {$u eq "toplevel"} {
lappend z "first called"
set mode [testservicemode 1]
set timer [after 50 lappend z timeout]
set u first
vwait z
after cancel $timer
testservicemode $mode
lappend z "first after update"
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
|
| ︙ | ︙ | |||
6522 6523 6524 6525 6526 6527 6528 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
| > | > > > > > > | | 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
chan close $f
} -result [list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after update}]
test chan-io-51.1 {Test old socket deletion on Macintosh} -setup {
|
| ︙ | ︙ | |||
6674 6675 6676 6677 6678 6679 6680 |
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 lf -blocking 0
chan configure $f2 -translation lf -blocking 0
| | | 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 |
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 lf -blocking 0
chan configure $f2 -translation lf -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
|
| ︙ | ︙ | |||
6705 6706 6707 6708 6709 6710 6711 |
} -cleanup {
chan close $f1
chan close $f2
} -result {0 0 ok}
test chan-io-52.8 {TclCopyChannel} -setup {
file delete $path(test1)
file delete $path(pipe)
| | | 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 |
} -cleanup {
chan close $f1
chan close $f2
} -result {0 0 ok}
test chan-io-52.8 {TclCopyChannel} -setup {
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan configure $f1 -translation lf
chan puts $f1 "
chan puts ready
chan gets stdin
set f1 \[open [list $thisScript] r\]
chan configure \$f1 -translation lf
|
| ︙ | ︙ | |||
6826 6827 6828 6829 6830 6831 6832 |
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)
| | | 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 |
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 {
set f1 [open $path(pipe) w]
chan puts -nonewline $f1 {
chan puts ready
chan flush stdout ;# Don't assume line buffered!
chan copy stdin stdout -command { set x }
vwait x
set f [}
|
| ︙ | ︙ | |||
6864 6865 6866 6867 6868 6869 6870 |
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
| | | 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 |
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
} -constraints {stdio unix fileevent fcopy} -body {
set f1 [open $path(pipe) w]
chan puts $f1 {
chan puts ready
chan copy stdin stdout -command { set x }
vwait x
set f [open $path(test1) w]
chan configure $f -translation lf
|
| ︙ | ︙ | |||
6916 6917 6918 6919 6920 6921 6922 |
set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]]
catch {unset fcopyTestDone}
chan close $listen ;# This means the socket open never really succeeds
chan copy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
| | | | | 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 |
set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]]
catch {unset fcopyTestDone}
chan close $listen ;# This means the socket open never really succeeds
chan copy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
chan close $in
chan close $out
set fcopyTestDone ;# 1 for error condition
} 1
test chan-io-53.6 {CopyData: error during chan copy} -setup {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan puts $f1 "exit 1"
chan close $f1
set in [openpipe r+ $path(pipe)]
set out [open $path(test1) w]
chan copy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
return $fcopyTestDone ;# 0 for plain end of file
} -cleanup {
catch {chan close $in}
chan close $out
} -result 0
|
| ︙ | ︙ | |||
6962 6963 6964 6965 6966 6967 6968 |
-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}
| | | 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 |
-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]} {
|
| ︙ | ︙ | |||
6989 6990 6991 6992 6993 6994 6995 |
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
# -1=error 0=script error N=number of bytes
| | | 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 |
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
# -1=error 0=script error N=number of bytes
expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1}
} -cleanup {
catch {chan close $in}
chan close $out
} -result {3450}
test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup {
# copy progress callback. errors out intentionally
proc cmd args {
|
| ︙ | ︙ | |||
7012 7013 7014 7015 7016 7017 7018 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
chan copy $f $g -size 2 -command [namespace code cmd]
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
|
| ︙ | ︙ | |||
7052 7053 7054 7055 7056 7057 7058 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; chan configure $f -translation binary
set g [open $bar w] ; chan configure $g -translation binary -buffering none
| | | 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; chan configure $f -translation binary
set g [open $bar w] ; chan configure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Initialize and force eof on the input.
chan seek $f 0 end ; chan read $f 1
set ::RES [chan eof $f]
# Run the copy. Should not invoke -command now.
chan copy $f $g -size 2 -command [namespace code cmd]
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
|
| ︙ | ︙ | |||
7110 7111 7112 7113 7114 7115 7116 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
| | | 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio fcopy} -body {
chan copy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
|
| ︙ | ︙ | |||
7183 7184 7185 7186 7187 7188 7189 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
chan configure $a -translation binary -buffering none
chan configure $b -translation binary -buffering none
chan event $a readable [namespace code "done $a"]
chan event $b readable [namespace code "done $b"]
| | | 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
chan configure $a -translation binary -buffering none
chan configure $b -translation binary -buffering none
chan event $a readable [namespace code "done $a"]
chan event $b readable [namespace code "done $b"]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
chan puts $a AB
vwait ::forever
chan puts $b BA
vwait ::forever
set ::forever
|
| ︙ | ︙ | |||
7405 7406 7407 7408 7409 7410 7411 |
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
| | | 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 |
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} {
set out [open $path(script) w]
chan puts $out {
chan puts "normal message from pipe"
chan puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ | |||
7443 7444 7445 7446 7447 7448 7449 |
# fully implements the moving of channels between threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
chan close $f
string equal $result [testmainthread]
} {1}
| | | 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 |
# fully implements the moving of channels between threads, i.e. 'Threads'.
set f [open $path(longfile) r]
set result [testchannel mthread $f]
chan close $f
string equal $result [testmainthread]
} {1}
test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out "catch {load $::tcltestlib Tcltest}"
chan puts $out {
chan puts [testbytestring \xe2]
exit 1
}
|
| ︙ | ︙ |
Changes to tests/clock.test.
1 2 3 4 5 6 7 8 | # clock.test -- # # This test file covers the 'clock' command that manipulates time. # # 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 |
# clock.test --
#
# This test file covers the 'clock' command that manipulates time.
#
# 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 © 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
| < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
|
| ︙ | ︙ | |||
35021 35022 35023 35024 35025 35026 35027 35028 35029 35030 35031 35032 35033 35034 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
| > > > > > > > > > > > > > > > > > > | 35020 35021 35022 35023 35024 35025 35026 35027 35028 35029 35030 35031 35032 35033 35034 35035 35036 35037 35038 35039 35040 35041 35042 35043 35044 35045 35046 35047 35048 35049 35050 35051 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.8a {clock add months, negative, over threshold of a year} {
set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1]
list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1]
} {2018-12-31 2018-11-30 2018-10-31 2018-09-30}
test clock-30.8b {clock add months, negative, over threshold of a year} {
set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1]
for {set i 1} {$i < 24} {incr i 1} {
set f1 [clock add $t -$i month -gmt 1]
set f2 [clock add $f1 $i month -gmt 1]
if {$f2 != $t} {
error "\[clock add $t -$i month -gmt 1\] does not consider\
\[clock add $f1 $i month -gmt 1\] != $t"
}
}
} {}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
|
| ︙ | ︙ | |||
35415 35416 35417 35418 35419 35420 35421 |
set problems
} {}
# Legacy tests
# clock clicks
test clock-33.1 {clock clicks tests} {
| | | | 35432 35433 35434 35435 35436 35437 35438 35439 35440 35441 35442 35443 35444 35445 35446 35447 35448 35449 35450 35451 35452 35453 35454 35455 35456 35457 35458 35459 |
set problems
} {}
# Legacy tests
# clock clicks
test clock-33.1 {clock clicks tests} {
expr {[clock clicks] + 1}
concat {}
} {}
test clock-33.2 {clock clicks tests} {
set start [clock clicks]
after 10
set end [clock clicks]
expr {$end > $start}
} {1}
test clock-33.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
} {1 {bad option "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
expr {[clock clicks -milliseconds] + 1}
concat {}
} {}
test clock-33.4a {clock milliseconds} {
expr { [clock milliseconds] + 1 }
concat {}
} {}
test clock-33.5 {clock clicks tests, millisecond timing test} {
|
| ︙ | ︙ | |||
35609 35610 35611 35612 35613 35614 35615 |
set time [clock scan "1/1/71" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
set time [clock scan "1/1/37" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,2037 00:00 GMT}
| < | 35626 35627 35628 35629 35630 35631 35632 35633 35634 35635 35636 35637 35638 35639 |
set time [clock scan "1/1/71" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} {
set time [clock scan "1/1/37" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,2037 00:00 GMT}
test clock-34.12 {clock scan, relative times} {
set time [clock scan "Oct 23, 1992 -1 day"]
clock format $time -format {%b %d, %Y}
} "Oct 22, 1992"
test clock-34.13 {clock scan, ISO 8601 base date format} {
set time [clock scan "19921023"]
clock format $time -format {%b %d, %Y}
|
| ︙ | ︙ | |||
35761 35762 35763 35764 35765 35766 35767 |
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i]
set monday [clock scan "monday 1 week ago" -base $dec1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
| < | 35777 35778 35779 35780 35781 35782 35783 35784 35785 35786 35787 35788 35789 35790 |
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i]
set monday [clock scan "monday 1 week ago" -base $dec1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.44 {2nd monday in november} {
set res {}
foreach i {91 92 93 94 95 96} {
set nov8th [clock scan 11/8/$i -gmt 1]
set monday [clock scan monday -base $nov8th -gmt 1]
lappend res [clock format $monday -format %Y-%m-%d -gmt 1]
}
|
| ︙ | ︙ | |||
35794 35795 35796 35797 35798 35799 35800 |
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.47 {ago with multiple relative units} {
set base [clock scan "12/31/1999 00:00:00"]
set res [clock scan "2 days 2 hours ago" -base $base]
expr {$base - $res}
} 180000
| < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 35809 35810 35811 35812 35813 35814 35815 35816 35817 35818 35819 35820 35821 35822 35823 35824 35825 35826 35827 35828 35829 35830 35831 35832 35833 35834 35835 35836 35837 35838 35839 35840 35841 35842 35843 35844 35845 35846 35847 35848 35849 35850 35851 35852 35853 35854 35855 35856 35857 35858 35859 35860 35861 35862 35863 35864 35865 35866 35867 35868 35869 35870 35871 35872 35873 35874 35875 35876 35877 35878 35879 35880 35881 35882 35883 35884 35885 35886 35887 35888 35889 35890 35891 35892 35893 35894 35895 35896 35897 35898 35899 35900 35901 35902 35903 35904 35905 35906 35907 35908 35909 35910 35911 35912 35913 35914 35915 |
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-34.47 {ago with multiple relative units} {
set base [clock scan "12/31/1999 00:00:00"]
set res [clock scan "2 days 2 hours ago" -base $base]
expr {$base - $res}
} 180000
test clock-34.48 {more than one ToD} {*}{
-body {clock scan {10:00 11:00}}
-returnCodes error
-result {unable to convert date-time string "10:00 11:00": more than one time of day in string}
}
test clock-34.49 {more than one date} {*}{
-body {clock scan {1/1/2001 2/2/2002}}
-returnCodes error
-result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string}
}
test clock-34.50 {more than one time zone} {*}{
-body {clock scan {10:00 EST CST}}
-returnCodes error
-result {unable to convert date-time string "10:00 EST CST": more than one time zone in string}
}
test clock-34.51 {more than one weekday} {*}{
-body {clock scan {Monday Tuesday}}
-returnCodes error
-result {unable to convert date-time string "Monday Tuesday": more than one weekday in string}
}
test clock-34.52 {more than one ordinal month} {*}{
-body {clock scan {next January next March}}
-returnCodes error
-result {unable to convert date-time string "next January next March": more than one ordinal month in string}
}
test clock-34.53 {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023T00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
test clock-34.54 {clock scan, ISO 8601 point in time format} {
set time [clock scan "1992-10-23T00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "19921023MST000000"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "19921023M000000"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "1992-10-23M00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body {
set time [clock scan "1992-10-23MST00:00:00"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} -returnCodes error -match glob -result {unable to convert date-time string*}
test clock-34.59 {clock scan tests (-TZ)} {
set time [clock scan "31 Jan 14 23:59:59 -0100"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Feb 01,2014 00:59:59 GMT}
test clock-34.60 {clock scan tests (+TZ)} {
set time [clock scan "31 Jan 14 23:59:59 +0100"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 31,2014 22:59:59 GMT}
test clock-34.61 {clock scan tests (-TZ)} {
set time [clock scan "23:59:59 -0100" -base 0 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 02,1970 00:59:59 GMT}
test clock-34.62 {clock scan tests (+TZ)} {
set time [clock scan "23:59:59 +0100" -base 0 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 01,1970 22:59:59 GMT}
test clock-34.63 {clock scan tests (TZ)} {
set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jun 30,2014 21:59:59 GMT}
test clock-34.64 {clock scan tests (TZ)} {
set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 31,2014 22:59:59 GMT}
test clock-34.65 {clock scan tests (relspec, day unit not TZ)} {
set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Feb 08,1970 23:59:59 GMT}
test clock-34.66 {clock scan tests (relspec, day unit not TZ)} {
set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 09,1970 23:59:59 GMT}
test clock-34.67 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm CET" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
test clock-34.68 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
# clock seconds
test clock-35.1 {clock seconds tests} {
expr {[clock seconds] + 1}
concat {}
} {}
test clock-35.2 {clock seconds tests} {
list [catch {clock seconds foo} msg] $msg
} {1 {wrong # args: should be "clock seconds"}}
test clock-35.3 {clock seconds tests} {
set start [clock seconds]
|
| ︙ | ︙ | |||
36925 36926 36927 36928 36929 36930 36931 |
clock format [clock seconds] -format %%r
} %r
test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
| < < < | 36997 36998 36999 37000 37001 37002 37003 37004 37005 37006 37007 37008 37009 37010 37011 37012 37013 37014 37015 37016 37017 37018 37019 37020 37021 37022 37023 37024 37025 |
clock format [clock seconds] -format %%r
} %r
test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.3 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup {
package require msgcat
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]]
msgcat::mclocale en_uk
lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]]
} -cleanup {
msgcat::mclocale $current
} -result {1 1}
test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup {
package require msgcat
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
set res [clock scan "01.01.1970" -locale current -format %x -gmt 1]
msgcat::mclocale en_uk
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
1 2 3 4 5 6 | # The file tests the tclCmdAH.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 |
# The file tests the tclCmdAH.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.
#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# 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.
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 testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint time64bit [expr {
$::tcl_platform(pointerSize) >= 8 ||
[llength [info command testsize]] && [testsize st_mtime] >= 8
}]
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)]}]
global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}
proc waitForEvenSecondForFAT {} {
# Windows 9x uses filesystems (the FAT* family of FSes) without enough
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body {
set volumeList [file volumes]
glob -nocomplain [lindex $volumeList 0]*
} -match glob -result *
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body {
set volumeList [string tolower [file volumes]]
set element [lsearch -exact $volumeList "c:/"]
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body {
set volumeList [file volumes]
glob -nocomplain [lindex $volumeList 0]*
} -match glob -result *
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body {
set volumeList [string tolower [file volumes]]
set element [lsearch -exact $volumeList "c:/"]
list [expr {$element>=0}] [glob -nocomplain [lindex $volumeList $element]*]
} -match glob -result {1 *}
# attributes
test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup {
set foofile [makeFile abcde foo.file]
catch {file delete -force $foofile}
} -body {
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
# the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
file delete -force /tmp/tcl.foo.dir/file
file delete -force /tmp/tcl.foo.dir
} -body {
makeDirectory /tmp/tcl.foo.dir
makeFile 12345 /tmp/tcl.foo.dir/file
| | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
# the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
file delete -force /tmp/tcl.foo.dir/file
file delete -force /tmp/tcl.foo.dir
} -body {
makeDirectory /tmp/tcl.foo.dir
makeFile 12345 /tmp/tcl.foo.dir/file
file attributes /tmp/tcl.foo.dir -permissions 0
file exists /tmp/tcl.foo.dir/file
} -cleanup {
file attributes /tmp/tcl.foo.dir -permissions 0o775
removeFile /tmp/tcl.foo.dir/file
removeDirectory /tmp/tcl.foo.dir
} -result 0
test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup {
set newdirfile [makeDirectory newdir.file]
set cwd [pwd]
cd $newdirfile
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
} -result {1 0}
# Stat related commands
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
| | | 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
} -result {1 0}
# Stat related commands
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0o765}
# avoid problems with non-local filesystems
if {[testConstraint unix] && [file exists /tmp]} {
set file [makeFile "data" touch.me /tmp]
} else {
set file [makeFile "data" touch.me]
}
|
| ︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 |
file lstat $linkfile stat
lsort [array names stat]
} -result {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup {
unset -nocomplain stat
} -constraints {unix nonPortable} -body {
file lstat $linkfile stat
| | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
file lstat $linkfile stat
lsort [array names stat]
} -result {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup {
unset -nocomplain stat
} -constraints {unix nonPortable} -body {
file lstat $linkfile stat
list $stat(nlink) [expr {$stat(mode) & 0o777}] $stat(type)
} -result {1 511 link}
test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
list [catch {file lstat _bogus_ stat} msg] [string tolower $msg] \
$errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup {
unset -nocomplain x
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
file owned $tmpfile
} -cleanup {
removeFile touch.me /tmp
} -result 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
file owned /
} 0
| | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
file owned $tmpfile
} -cleanup {
removeFile touch.me /tmp
} -result 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
file owned /
} 0
test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win notWine} -body {
if {[info exists env(SystemRoot)]} {
file owned $env(SystemRoot)
} else {
file owned $env(windir)
}
} -result 0
test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body {
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 |
}
set res
} -result 0
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
| | | 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
}
set res
} -result 0
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0o765}
# stat
test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body {
file stat _bogus_
} -result {wrong # args: should be "file stat name varName"}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body {
file stat _bogus_ a b
|
| ︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 |
file stat $gorpfile stat
list $stat(nlink) $stat(size) $stat(type)
} -result {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup {
unset -nocomplain stat
} -body {
file stat $gorpfile stat
| | | | 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 |
file stat $gorpfile stat
list $stat(nlink) $stat(size) $stat(type)
} -result {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup {
unset -nocomplain stat
} -body {
file stat $gorpfile stat
format 0o%03o [expr {$stat(mode) & 0o777}]
} -result 0o765
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
list [catch {file stat _bogus_ stat} msg] [string tolower $msg] $errorCode
} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test cmdAH-28.7 {Tcl_FileObjCmd: stat} -setup {
unset -nocomplain x
} -returnCodes error -body {
set x 44
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
} -body {
# Unlike [exec ln -s], [file link] requires an existing target
file link -symbolic $linkfile $gorpfile
file type $linkfile
} -cleanup {
file delete $linkfile
} -result link
| | | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
} -body {
# Unlike [exec ln -s], [file link] requires an existing target
file link -symbolic $linkfile $gorpfile
file type $linkfile
} -cleanup {
file delete $linkfile
} -result link
test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory notWine} -setup {
set tempdir [makeDirectory temp]
} -body {
set linkdir [file join [temporaryDirectory] link.dir]
file link -symbolic $linkdir $tempdir
file type $linkdir
} -cleanup {
file delete $linkdir
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
} [list $newFileId $newFileId]
test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
lsort [safeInterp eval [list file channels]]
} [lsort [list stdout $newFileId]]
test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
| | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 |
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
} [list $newFileId $newFileId]
test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
lsort [safeInterp eval [list file channels]]
} [lsort [list stdout $newFileId]]
test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
# we can now write to $newFileId from child
safeInterp eval [list puts $newFileId "hello"]
} {}
interp transfer {} $newFileId safeInterp
test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {
# $newFileId should now be visible only in safeInterp
list [file channels $newFileId] \
[safeInterp eval [list file channels $newFileId]]
|
| ︙ | ︙ | |||
1767 1768 1769 1770 1771 1772 1773 |
# cleanup
catch {testsetplatform $platform}
unset -nocomplain platform
# Tcl_ForObjCmd is tested in for.test
| | | 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 |
# cleanup
catch {testsetplatform $platform}
unset -nocomplain platform
# Tcl_ForObjCmd is tested in for.test
catch {file attributes $dirfile -permissions 0o777}
removeDirectory $dirfile
removeFile $gorpfile
# No idea how well [removeFile] copes with links...
file delete $linkfile
cd $cmdAHwd
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/cmdIL.test.
1 2 3 4 | # This file contains a collection of tests for the procedures in the file # tclCmdIL.c. 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 |
# This file contains a collection of tests for the procedures in the file
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
source [file join [file dirname [info script]] internals.tcl]
namespace import -force ::tcltest::internals::*
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
| | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
} -returnCodes error -result {index "-2" out of range}
test cmdIL-1.42 {lsort -stride and-index} -body {
lsort -stride 2 -index -1-1 {a 2 b 1}
} -returnCodes error -result {index "-1-1" out of range}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup {
set result {}
set r 1435753299
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
| | | | | | | 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 |
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-1-1" out of range}
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-2" out of range}
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element end-4 missing from sublist "1 . c"}
test cmdIL-3.5.5 {SortCompare procedure, -index option} {
lsort -index {} {a b}
} {a b}
test cmdIL-3.5.6 {SortCompare procedure, -index option} {
lsort -index {} [list a \{]
} {a \{}
test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end--1" out of range}
test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+1" out of range}
test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+2" out of range}
test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 0 {{}}
} -returnCodes error -result {element 0 missing from sublist ""}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
test cmdIL-3.7 {SortCompare procedure, -ascii option} {
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
} {{dogs {0 1}} {the {0 1 2} lazy} {jumps {30 31 2 33} over} {brown {0 1 2 3 4} fox} {the {0 1 2 3 4 5} quick}}
test cmdIL-5.5 {lsort with list style index and sharing} -body {
proc test_lsort {l} {
set n $l
foreach e $l {lappend n [list [expr {rand()}] $e]}
lindex [lsort -real -index $l $n] 1 1
}
| | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
} {{dogs {0 1}} {the {0 1 2} lazy} {jumps {30 31 2 33} over} {brown {0 1 2 3 4} fox} {the {0 1 2 3 4 5} quick}}
test cmdIL-5.5 {lsort with list style index and sharing} -body {
proc test_lsort {l} {
set n $l
foreach e $l {lappend n [list [expr {rand()}] $e]}
lindex [lsort -real -index $l $n] 1 1
}
expr {srand(1)}
test_lsort 0
} -result 0 -cleanup {
rename test_lsort ""
}
test cmdIL-5.6 {lsort with multiple list-style index options} {
lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}}
} {{a b} {b e} {c d}}
|
| ︙ | ︙ |
Changes to tests/cmdInfo.test.
1 2 3 4 5 6 7 8 | # Commands covered: none # # This file contains a collection of tests for Tcl_GetCommandInfo, # Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and # Tcl_NameOfCommand. 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_GetCommandInfo,
# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and
# Tcl_NameOfCommand. Sourcing this file into Tcl runs the tests
# and generates output for errors. No output means no errors were
# found.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# 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.
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 testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
1 2 3 4 5 6 | # The tests in this file cover the procedures in tclCmdMZ.c. # # 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 |
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::customMatch
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
file delete -force $foodir
file mkdir $foodir
cd $foodir
} -constraints {unix nonPortable} -body {
# This test fails on various unix platforms (eg Linux) where permissions
# caching causes this to fail. The caching is strictly incorrect, but we
# have no control over that.
| | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
file delete -force $foodir
file mkdir $foodir
cd $foodir
} -constraints {unix nonPortable} -body {
# This test fails on various unix platforms (eg Linux) where permissions
# caching causes this to fail. The caching is strictly incorrect, but we
# have no control over that.
file attr . -permissions 0
pwd
} -returnCodes error -cleanup {
cd $cwd
file delete -force $foodir
} -result {error getting working directory name: permission denied}
# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: expr # # This file contains the original set of tests for the compilation (and # indirectly execution) of Tcl's expr command. A new set of tests covering # the new implementation are in the files "parseExpr.test" and # "compExpr.test". 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 |
# Commands covered: expr
#
# This file contains the original set of tests for the compilation (and
# indirectly execution) of Tcl's expr command. A new set of tests covering
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# 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.
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]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
set ::errorInfo
} -match glob -result {too many arguments for math function*
while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
catch {expr sin()} msg
set ::errorInfo
| | | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
set ::errorInfo
} -match glob -result {too many arguments for math function*
while *ing
"expr sin(1,2,3)"}
test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
catch {expr sin()} msg
set ::errorInfo
} -match glob -result {not enough arguments for math function*
while *ing
"expr sin()"}
test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body {
catch {expr pow(1)} msg
set ::errorInfo
} -match glob -result {not enough arguments for math function*
while *ing
"expr pow(1)"}
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -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}
|
| ︙ | ︙ |
Changes to tests/compExpr.test.
1 2 3 4 | # This file contains a collection of tests for the procedures in the file # tclCompExpr.c. 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 |
# This file contains a collection of tests for the procedures in the file
# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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]]
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
catch {unset a}
test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
expr {0? 42 : $a}
} -result 83
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
list [catch {expr {1? 15 : [expr *2]}} msg] $msg
} {0 15}
test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
| | | | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
expr {0? 42 : $a}
} -result 83
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
list [catch {expr {1? 15 : [expr *2]}} msg] $msg
} {0 15}
test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
format %.6g [expr {atan2(1.0, 2.0)}]
} 0.463648
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
expr {do_it()}
} -returnCodes error -match glob -result {* "*do_it"}
test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {not enough arguments for math function*}
test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} {
format %.6g [expr {pow(2.1, 27.5-(24.4*(5%2)))}]
} 9.97424
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body {
expr {sinh(2.*)}
} -returnCodes error -match glob -result *
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body {
expr {sinh(2.0, 3.0)}
} -returnCodes error -match glob -result {too many arguments for math function*}
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
proc getbytes {} {
set lines [split [memory info] \n]
lindex $lines 3 3
}
} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
| | | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
proc getbytes {} {
set lines [split [memory info] \n]
lindex $lines 3 3
}
} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
interp create child
child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
interp delete child
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
rename getbytes {}
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
rename getbytes {}
} -result 0
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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}
catch {unset b}
catch {rename extract ""}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/compile.test.
1 2 3 4 5 6 7 | # This file contains tests for the files tclCompile.c, tclCompCmds.c and # tclLiteral.c # # 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 |
# This file contains tests for the files tclCompile.c, tclCompCmds.c and
# tclLiteral.c
#
# 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 © 1997 Sun Microsystems, Inc.
# 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.
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 exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
-cleanup {namespace delete catchtest}
}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
| | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
-cleanup {namespace delete catchtest}
}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
for {} [expr {$i < 3}] {} {
set j [incr i]
if {$j > 3} break
}
set j
} {4}
test compile-5.1 {TclCompileForeachCmd: exception stack} {
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
list $::x $::test_ns_compile::arr(1)
} -result {hello 123}
test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
| | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
list $::x $::test_ns_compile::arr(1)
} -result {hello 123}
test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
while [expr {$i < 3}] {
set j [incr i]
if {$j > 3} break
}
set j
} {4}
test compile-8.1 {CollectArgInfo: binary data} {
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; incr foo bar baz}}
} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"}
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; incr}}
} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"}
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
| | | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; incr foo bar baz}}
} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"}
test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; incr}}
} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"}
test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; expr [concat !a] }}
} -returnCodes error -match glob -result *
test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; expr {!a} }}
} -returnCodes error -match glob -result *
test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; llength "\{" }}
list [catch {p} msg] $msg
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
test compile-15.5 {proper TCL_RETURN code from [return]} {
apply {{} {catch {set a 1}; return}}
} ""
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
| | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
test compile-15.5 {proper TCL_RETURN code from [return]} {
apply {{} {catch {set a 1}; return}}
} ""
# Do all tests once byte compiled and once with direct string evaluation
foreach noComp {0 1} {
if {$noComp} {
interp alias {} run {} testevalex
set constraints testevalex
} else {
interp alias {} run {} if 1
set constraints {}
}
|
| ︙ | ︙ |
Changes to tests/concat.test.
1 2 3 4 5 6 | # Commands covered: concat # # 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 |
# Commands covered: concat
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test concat-1.1 {simple concatenation} {
concat a b c d e f g
} {a b c d e f g}
test concat-1.2 {merging lists together} {
|
| ︙ | ︙ |
Changes to tests/config.test.
1 2 3 4 5 6 7 | # -*- tcl -*- # Commands covered: pkgconfig # # 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 |
# -*- tcl -*-
# Commands covered: pkgconfig
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test pkgconfig-1.1 {query keys} {
lsort [::tcl::pkgconfig list]
} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime}
test pkgconfig-1.2 {query keys multiple times} {
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
1 2 3 4 5 6 | # Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # | | | | | | 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 |
# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright © 2008 Miguel Sofer.
#
# 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 testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
coroutine demo apply {{} { foreach i {1 2} yield; error test }}
demo
set ::result none
tcl::unsupported::inject demo set ::result inject-executed
lappend ::result [catch {demo} err] $err
} -result {inject-executed 1 test}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
| | | | | | | | | | 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 |
coroutine demo apply {{} { foreach i {1 2} yield; error test }}
demo
set ::result none
tcl::unsupported::inject demo set ::result inject-executed
lappend ::result [catch {demo} err] $err
} -result {inject-executed 1 test}
test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
interp create child
child eval {
coroutine demo apply {{} { while {1} yield }}
demo
tcl::unsupported::inject 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
tcl::unsupported::inject demo set ::result inject-executed
}
child eval demo
set result [child eval {set ::result}]
interp delete child
set result
} -result {inject-executed}
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 {
|
| ︙ | ︙ |
Changes to tests/dcall.test.
1 2 3 4 5 6 | # Commands covered: none # # This file contains a collection of tests for Tcl_CallWhenDeleted. # 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_CallWhenDeleted.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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.
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 testdcall [llength [info commands testdcall]]
test dcall-1.1 {deletion callbacks} testdcall {
lsort -increasing [testdcall 1 2 3]
} {1 2 3}
test dcall-1.2 {deletion callbacks} testdcall {
|
| ︙ | ︙ |
Changes to tests/dict.test.
1 2 3 4 5 6 7 | # This test file covers the dictionary object type and the dict command used # to work with values of that type. # # 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 |
# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# 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 © 2003-2009 Donal K. Fellows
# 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::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ |
Changes to tests/dstring.test.
1 2 3 4 5 6 | # Commands covered: none # # This file contains a collection of tests for Tcl's dynamic string library # procedures. 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl's dynamic string library
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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.
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 testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
testdstring free
}
test dstring-1.1 {appending and retrieving} -constraints testdstring -setup {
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
| | > > | < | > > > > > > > > > > > > > > > > > > > > | 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 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.13 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.14 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append " " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result { {#}}
test dstring-2.15 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-3.1 {nested sublists} -constraints testdstring -setup {
testdstring free
} -body {
testdstring start
testdstring element foo
testdstring element bar
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
| | > > | < | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.10 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.11 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append x -1
testdstring start
testdstring append " " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x { {#}}}
test dstring-3.12 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-4.1 {truncation} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append "abcdefg" -1
testdstring trunc 3
list [testdstring get] [testdstring length]
|
| ︙ | ︙ |
Changes to tests/encoding.test.
1 2 3 4 | # This file contains a collection of tests for tclEncoding.c # 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 |
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::encoding {
variable x
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
}
proc toutf {args} {
variable x
lappend x "toutf $args"
}
proc fromutf {args} {
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
set x {}
encoding convertto foo abcd
testencoding delete foo
return $x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
| | | | | | | | 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 |
testencoding create foo [namespace origin toutf] [namespace origin fromutf]
set x {}
encoding convertto foo abcd
testencoding delete foo
return $x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
list [encoding convertto jis0208 乎] \
[encoding convertfrom jis0208 8C]
} "8C 乎"
test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
encoding convertto jis0208 乎
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
set system [encoding system]
set path [encoding dirs]
} -constraints {testencoding} -body {
encoding system shiftjis ;# incr ref count
encoding dirs [list [pwd]]
set x [encoding convertto shiftjis 乎] ;# old one found
encoding system iso8859-1
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
lappend x [catch {encoding convertto shiftjis 乎} msg] $msg
} -cleanup {
encoding system iso8859-1
encoding dirs $path
encoding system $system
} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}"
test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
set old [encoding system]
} -body {
encoding system shiftjis
encoding system
} -cleanup {
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
removeDirectory tmp
} -result {junk junk2}
test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
set old [encoding system]
} -body {
encoding system jis0208
| | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
removeDirectory tmp
} -result {junk junk2}
test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
set old [encoding system]
} -body {
encoding system jis0208
encoding convertto 乎
} -cleanup {
encoding system iso8859-1
encoding system $old
} -result {8C}
test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
set old [encoding system]
encoding system $old
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
encoding convertto foo abcd
testencoding delete foo
return $x
} {{toutf a} {fromutf b}}
test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
encoding convertfrom jis0208 8c8c8c8c
| | | | | | | | 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 |
encoding convertto foo abcd
testencoding delete foo
return $x
} {{toutf a} {fromutf b}}
test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
encoding convertfrom jis0208 8c8c8c8c
} "å¾å¾å¾å¾"
test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
append a $a
append a $a
append a $a
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 -encoding iso8859-1
puts -nonewline $f "ab\x8c\xc1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -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} {
encoding convertto jis0208 "å¾å¾å¾å¾"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
set a 乎乎乎乎乎乎乎乎
append a $a
append a $a
append a $a
append a $a
append a $a
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 binary -encoding shiftjis
puts -nonewline $f "ab乎g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 |
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
encoding dirs {}
llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal
| | | | | | | | | | | | | > > > > > | | | | | | | | | | | | | | | | | | | | | | | 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 |
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
encoding dirs {}
llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal
set x [list [catch {encoding convertto jis0208 乎} msg] $msg]
encoding dirs $path
encoding system $system
lappend x [encoding convertto jis0208 乎]
} {1 {unknown encoding "jis0208"} 8C}
test encoding-11.2 {LoadEncodingFile: single-byte} {
encoding convertfrom jis0201 \xA1
} "。"
test encoding-11.3 {LoadEncodingFile: double-byte} {
encoding convertfrom jis0208 8C
} 乎
test encoding-11.4 {LoadEncodingFile: multi-byte} {
encoding convertfrom shiftjis \x8C\xC1
} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
viewable [encoding convertto iso2022 乎]
} [viewable "\x1B\$B8C\x1B(B"]
test encoding-11.5.1 {LoadEncodingFile: escape file} {
viewable [encoding convertto iso2022-jp 乎]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
} -body {
cd [temporaryDirectory]
encoding dirs [file join tmp encoding]
makeDirectory tmp
makeDirectory [file join tmp encoding]
set f [open [file join tmp encoding splat.enc] w]
fconfigure $f -translation binary
puts $f "abcdefghijklmnop"
close $f
encoding convertto splat 乎
} -returnCodes error -cleanup {
file delete [file join [temporaryDirectory] tmp encoding splat.enc]
removeDirectory [file join tmp encoding]
removeDirectory tmp
cd [workingDirectory]
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
test encoding-11.8 {encoding: extended Unicode UTF-16} {
viewable [encoding convertto utf-16le 😹]
} {=Ø9Þ (=\u00d89\u00de)}
test encoding-11.9 {encoding: extended Unicode UTF-16} {
viewable [encoding convertto utf-16be 😹]
} {Ø=Þ9 (\u00d8=\u00de9)}
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
set x [encoding convertto iso8859-3 \u0120]
append x [encoding convertto iso8859-3 \xD5]
append x [encoding convertfrom iso8859-3 \xD5]
} "\xD5?\u120"
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
set x [encoding convertto iso8859-3 ab\u0120g]
append x [encoding convertfrom iso8859-3 ab\xD5g]
} "ab\xD5gab\u120g"
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
set x [encoding convertto shiftjis ab乎g]
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
} "ab\x8C\xC1gab乎g"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
set x [encoding convertto jis0208 乎α]
append x [encoding convertfrom jis0208 8C&A]
} "8C&A乎α"
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
set x [encoding convertto symbol γ]
append x [encoding convertto symbol g]
append x [encoding convertfrom symbol g]
} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
viewable [set x [encoding convertto iso2022 ab乎棙g]]
} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"]
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 \xA3
} "\xC2\xA3"
test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z
set z
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]]
binary scan [teststringbytes $y] H* z
set z
} c080
test encoding-15.4 {UtfToUtfProc emoji character input} -body {
set x \xED\xA0\xBD\xED\xB8\x82
set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82]
list [string length $x] $y
} -result "6 😂"
test encoding-15.5 {UtfToUtfProc emoji character input} {
set x \xF0\x9F\x98\x82
set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82]
list [string length $x] $y
} "4 😂"
test encoding-15.6 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\uDE02\uD83D
set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D]
binary scan $y H* z
list [string length $y] $z
} {10 edb882f09f9882eda0bd}
test encoding-15.7 {UtfToUtfProc emoji character output} {
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 |
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
| | > > > > > | | | | 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 |
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2]
list [string length $x] $y
} "4 \xF0\xA0\xA1\xC2"
test encoding-15.17 {UtfToUtfProc emoji character output} {
set x 😂
set y [encoding convertto utf-8 😂]
binary scan $y H* z
list [string length $y] $z
} {4 f09f9882}
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"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
test encoding-16.3 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xDC\xDC"]
list $val [format %x [scan $val %c]]
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
| | | | | | | | | | | | | | 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 |
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
viewable [runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab乎棙g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}]
} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
set a "乎乞也"; # 3 Japanese Kanji letters
puts $a
} iso2022.tcl]
set f [open "|[list [interpreter] $file]"]
fconfigure $f -encoding iso2022-jp
set count [gets $f line]
close $f
removeFile iso2022.tcl
list $count [viewable $line]
} [list 3 "乎乞也 (\\u4e4e\\u4e5e\\u4e5f)"]
test encoding-24.4 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC0\x80"]
} 1
test encoding-24.5 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC0\x81"]
} 2
test encoding-24.6 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC1\xBF"]
} 2
test encoding-24.7 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC2\x80"]
} 1
test encoding-24.8 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xE0\x80\x80"]
} 3
test encoding-24.9 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"]
} 3
test encoding-24.10 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xE0\xA0\x80"]
} 1
test encoding-24.11 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"]
} 1
file delete [file join [temporaryDirectory] iso2022.txt]
#
# Begin jajp encoding round-trip conformity tests
#
|
| ︙ | ︙ |
Changes to tests/env.test.
1 2 3 4 5 6 | # Commands covered: none (tests environment variable implementation) # # 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 |
# Commands covered: none (tests environment variable implementation)
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
package require tcltests
# [exec] is required here to see the actual environment received by child
# processes.
proc getenv {} {
global printenvScript
catch {exec [interpreter] $printenvScript} out
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
encodingrestore
envrestore
}
variable keep {
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
| | > | > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
encodingrestore
envrestore
}
variable keep {
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
CommonProgramFiles CommonProgramFiles(x86) ProgramFiles
ProgramFiles(x86) CommonProgramW6432 ProgramW6432
WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR
}
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
encoding system iso8859-1
proc lrem {listname name} {
upvar $listname list
set i [lsearch -nocase $list $name]
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
set env(XYZZY) "garbage"
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-3.1 {
changing environment variables
} -constraints exec -setup setup2 -body {
set result [getenv]
unset env(NAME2)
set result
| > > > > > > > > > > > > > > > > > > > > | 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 |
set env(XYZZY) "garbage"
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
# be sure set of (unicode) environment occurs if single-byte encoding is used:
encodingswitch cp1252
# german (cp1252) and russian (cp1251) characters together encoded as utf-8:
set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d
set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]]
# now switch to utf-8 (to see correct values from test):
encoding system utf-8
} -body {
exec [interpreter] << [string map [list \$val $val] {
encoding system utf-8; fconfigure stdout -encoding utf-8
set test [encoding convertfrom utf-8 [binary decode hex $val]]
puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\
$env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\
$test ([binary encode hex [encoding convertto $test]])"
}]
} -cleanup {
encodingrestore
unset -nocomplain val f env(XYZZY)
} -match glob -result {1 *}
test env-3.1 {
changing environment variables
} -constraints exec -setup setup2 -body {
set result [getenv]
unset env(NAME2)
set result
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
}
info exists env(THIS_SHOULDNT_EXIST)
} -cleanup {
interp delete i
} -result {0}
| | | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
}
info exists env(THIS_SHOULDNT_EXIST)
} -cleanup {
interp delete i
} -result {0}
test env-5.3 {corner cases: unset the env in parent should unset child} -setup {
setup1
interp create i
} -body {
# Variables deleted in a parent interp should be deleted in child interp
# too.
i eval {set env(THIS_SHOULD_EXIST) a}
set result [set env(THIS_SHOULD_EXIST)]
unset env(THIS_SHOULD_EXIST)
lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
} -cleanup {
cleanup1
|
| ︙ | ︙ |
Changes to tests/error.test.
1 2 3 4 5 6 | # Commands covered: error, catch, throw, try # # 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 |
# Commands covered: error, catch, throw, try
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
customMatch pairwise {apply {{a b} {
string equal [lindex $b 0] [lindex $b 1]
}}}
|
| ︙ | ︙ |
Changes to tests/eval.test.
1 2 3 4 5 6 | # Commands covered: eval # # 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 |
# Commands covered: eval
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test eval-1.1 {single argument} {
eval {format 22}
} 22
test eval-1.2 {multiple arguments} {
|
| ︙ | ︙ |
Changes to tests/event.test.
1 2 3 4 5 | # This file contains a collection of tests for the procedures in the file # tclEvent.c, which includes the "update", and "vwait" Tcl 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 41 42 43 44 |
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
# Copyright © 1995-1997 Sun Microsystems, Inc.
# 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.
package require tcltest 2.5
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::tcltestlib [info loaded {} Tcltest]
}
testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]
testConstraint exec [llength [info commands exec]]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
testfilehandler close
set result ""
} -constraints {testfilehandler notOSX} -body {
testfilehandler create 0 readable off
testfilehandler clear 0
testfilehandler oneevent
lappend result [testfilehandler counts 0]
testfilehandler fillpartial 0
update idletasks
testfilehandler oneevent
lappend result [testfilehandler counts 0]
testfilehandler oneevent
lappend result [testfilehandler counts 0]
} -cleanup {
testfilehandler close
} -result {{0 0} {1 0} {2 0}}
|
| ︙ | ︙ |
Changes to tests/exec.test.
1 2 3 4 5 6 | # Commands covered: exec # # 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 |
# Commands covered: exec
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# 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.
# There is no point in running Valgrind on cases where [exec] forks but then
# fails and the child process doesn't go through full cleanup.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
package require tcltests
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
# Some skips when running in a macOS CI environment
testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
| > > | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
#
# This test also fails in some cases when building with macOS
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosxCI} -setup {
set tmpfile [makeFile {0} tmpfile.exec-19.1]
} -body {
# Note that we have to allow for the current contents of the temporary
# file, which is why the result is 14 and not 12
exec /bin/sh -c \
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
|
| ︙ | ︙ |
Changes to tests/execute.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the tclExecute.c source file. Tests appear in # the same order as the C code that they test. The set of tests is currently # incomplete since it currently includes only new tests for code changed for # the addition of Tcl namespaces. Other execution-related tests appear in # several other test files including namespace.test, basic.test, eval.test, # for.test, etc. # # 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 |
# This file contains tests for the tclExecute.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is currently
# incomplete since it currently includes only new tests for code changed for
# the addition of Tcl namespaces. Other execution-related tests appear in
# several other test files including namespace.test, basic.test, eval.test,
# for.test, etc.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 |
proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
} -cleanup {
namespace delete foo
} -result {0 AHA!}
test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
} -cleanup {
namespace delete foo
} -result {0 AHA!}
test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
interp create child
} -body {
set script { llength {} }
child eval {proc llength args {return AHA!}}
set result {}
lappend result [if 1 $script]
lappend result [child eval $script]
} -cleanup {
interp delete child
} -result {0 AHA!}
test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
set script { llength {} }
interp create child
set result {}
lappend result [child eval $script]
interp delete child
interp create child
lappend result [child eval $script]
} -cleanup {
catch {interp delete child}
} -result {0 0}
test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
interp create child
} -constraints testexprlongobj -body {
set e { [llength {}]+1 }
set result {}
load {} Tcltest child
interp alias {} e child testexprlongobj
lappend result [e $e]
interp delete child
interp create child
load {} Tcltest child
interp alias {} e child testexprlongobj
lappend result [e $e]
} -cleanup {
interp delete child
} -result {{This is a result: 1} {This is a result: 1}}
test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
interp create child
} -body {
set e { [llength {}]+1 }
set result {}
interp alias {} e child expr
lappend result [e $e]
interp delete child
interp create child
interp alias {} e child expr
lappend result [e $e]
} -cleanup {
interp delete child
} -result {1 1}
test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
set e { [llength {}]+1 }
set result {}
lappend result [expr $e]
set origName [namespace which llength]
rename $origName llength.orig
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
proc llength {args} {return 1}
}
lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
| | | | | | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 |
proc llength {args} {return 1}
}
lappend result [namespace eval foo [list expr $e]]
} -cleanup {
namespace delete foo
} -result {1 2}
test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
interp create child
} -body {
set e { [llength {}]+1 }
interp alias {} e child expr
child eval {proc llength args {return 1}}
set result {}
lappend result [expr $e]
lappend result [e $e]
} -cleanup {
interp delete child
} -result {1 2}
test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
proc foo e {set v 0; expr $e}
proc bar e {set v 1; expr $e}
set e { $v }
set result {}
lappend result [foo $e]
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 |
test execute-7.9 {Wide int handling in INST_MOD} {
expr {(wide(1)<<60) % ((wide(47)<<45)-1)}
} 316659348800185
test execute-7.10 {Wide int handling in INST_MOD} {
expr {((wide(1)<<60)-1) % 0x400000000}
} 17179869183
test execute-7.11 {Wide int handling in INST_LSHIFT} {
| | | | | | | | | | | | | | | | | 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 |
test execute-7.9 {Wide int handling in INST_MOD} {
expr {(wide(1)<<60) % ((wide(47)<<45)-1)}
} 316659348800185
test execute-7.10 {Wide int handling in INST_MOD} {
expr {((wide(1)<<60)-1) % 0x400000000}
} 17179869183
test execute-7.11 {Wide int handling in INST_LSHIFT} {
expr {wide(42) << 30}
} 45097156608
test execute-7.12 {Wide int handling in INST_LSHIFT} {
expr {12345678901 << 3}
} 98765431208
test execute-7.13 {Wide int handling in INST_RSHIFT} {
expr {0x543210febcda9876 >> 7}
} 47397893236700464
test execute-7.14 {Wide int handling in INST_RSHIFT} {
expr {wide(0x9876543210febcda) >> 7}
} -58286587177206407
test execute-7.15 {Wide int handling in INST_BITOR} {
expr {wide(0x9876543210febcda) | 0x543210febcda9876}
} -2560765885044310786
test execute-7.16 {Wide int handling in INST_BITXOR} {
expr {wide(0x9876543210febcda) ^ 0x543210febcda9876}
} -3727778945703861076
test execute-7.17 {Wide int handling in INST_BITAND} {
expr {wide(0x9876543210febcda) & 0x543210febcda9876}
} 1167013060659550290
test execute-7.18 {Wide int handling in INST_ADD} {
expr {wide(0x7fffffff) + wide(0x7fffffff)}
} 4294967294
test execute-7.19 {Wide int handling in INST_ADD} {
expr {0x7fffffff + wide(0x7fffffff)}
} 4294967294
test execute-7.20 {Wide int handling in INST_ADD} {
expr {wide(0x7fffffff) + 0x7fffffff}
} 4294967294
test execute-7.21 {Wide int handling in INST_ADD} {
expr {double(0x7fffffff) + wide(0x7fffffff)}
} 4294967294.0
test execute-7.22 {Wide int handling in INST_ADD} {
expr {wide(0x7fffffff) + double(0x7fffffff)}
} 4294967294.0
test execute-7.23 {Wide int handling in INST_SUB} {
expr {0x123456789a - 0x20406080a}
} 69530054800
test execute-7.24 {Wide int handling in INST_MULT} {
expr {0x123456789a * 193}
} 15090186251290
test execute-7.25 {Wide int handling in INST_DIV} {
expr {0x123456789a / 193}
} 405116546
test execute-7.26 {Wide int handling in INST_UPLUS} {
set x 0x123456871234568
expr {+ $x}
} 81985533099853160
test execute-7.27 {Wide int handling in INST_UMINUS} {
set x 0x123456871234568
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
while executing
"error FOO"
invoked from within
"catch \[list error FOO\] m o"} -errorline 2}
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
interp create child
child eval {
package require tcltest 2.5
catch [list package require -exact tcl::test [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
child eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
}
child eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
}
child eval {
catch {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
}
child eval {set res}
} -cleanup {
interp delete child
} -result [lrepeat 4 A B]
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
interp create child
child eval {
package require tcltest 2.5
catch [list package require -exact tcl::test [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
}
} -body {
set res {}
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
}
} e] $e
lappend res [catch {
child eval {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
} e] $e
list $res [child eval {set res}]
} -cleanup {
interp delete child
} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
test execute-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
catch {error foo}
expr {1/$c}
}
if {[string match *foo* $::errorInfo]} {
set result "Bad errorInfo: $::errorInfo"
} else {
set result SUCCESS
}
set result
} SUCCESS
test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
} {48 {304 304}}
test execute-10.2 {Bug 2802881} -setup {
interp create child
} -body {
# If [Bug 2802881] is not fixed, this will segfault
child eval {
trace add variable ::errorInfo write {expr {$foo} ;#}
proc demo {} {a {}{}}
demo
}
} -cleanup {
interp delete child
} -returnCodes error -match glob -result *
test execute-10.3 {Bug 3072640} -setup {
proc generate {n} {
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
|
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 |
unset ::foo
rename generate {}
rename t {}
rename coro {}
} -result 4
test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
| | | | | 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 |
unset ::foo
rename generate {}
rename t {}
rename coro {}
} -result 4
test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
interp create child
} -body {
child eval {
set x [lrepeat 1320 199]
for {set i 0} {$i < 20} {incr i} {
lappend x $i
lsort -integer $x
}
# Crashes on failure
return ok
}
} -cleanup {
interp delete child
} -result ok
test execute-11.2 {Bug 268b23df11} -setup {
proc zero {} {return 0}
proc crash {} {expr {abs([zero])}}
proc noop args {}
trace add execution crash enterstep noop
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: expr # # This file contains the original set of tests for Tcl's expr command. # Since the expr command is now compiled, a new set of tests covering # the new implementation are in the files "parseExpr.test" and # "compExpr.test". 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 |
# Commands covered: expr
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# 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.
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 testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 |
test expr-old-26.10a {error conditions} !ieeeFloatingPoint {
list [catch {expr 2.0/0.0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10b {error conditions} ieeeFloatingPoint {
list [catch {expr 2.0/0.0} msg] $msg
} {0 Inf}
test expr-old-26.11 {error conditions} -body {
| | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
test expr-old-26.10a {error conditions} !ieeeFloatingPoint {
list [catch {expr 2.0/0.0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.10b {error conditions} ieeeFloatingPoint {
list [catch {expr 2.0/0.0} msg] $msg
} {0 Inf}
test expr-old-26.11 {error conditions} -body {
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 {can't use non-numeric string as operand of "/"}}
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} -body {
list [catch {expr rand(24)} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test expr-old-32.47 {math functions in expressions} -body {
list [catch {expr srand()} msg] $msg
| | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} -body {
list [catch {expr rand(24)} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test expr-old-32.47 {math functions in expressions} -body {
list [catch {expr srand()} msg] $msg
} -match glob -result {1 {not enough arguments for math function*}}
test expr-old-32.48 {math functions in expressions} -body {
expr srand(3.79)
} -returnCodes error -match glob -result *
test expr-old-32.49 {math functions in expressions} -body {
expr srand("")
} -returnCodes error -match glob -result *
test expr-old-32.50 {math functions in expressions} {
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
expr hypot(1.0, 2.0
} -returnCodes error -match glob -result *
test expr-old-34.6 {errors in math functions} -body {
expr hypot(1.0 ,
} -returnCodes error -match glob -result *
test expr-old-34.7 {errors in math functions} -body {
list [catch {expr hypot(1.0)} msg] $msg
| | | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 |
expr hypot(1.0, 2.0
} -returnCodes error -match glob -result *
test expr-old-34.6 {errors in math functions} -body {
expr hypot(1.0 ,
} -returnCodes error -match glob -result *
test expr-old-34.7 {errors in math functions} -body {
list [catch {expr hypot(1.0)} msg] $msg
} -match glob -result {1 {not enough arguments for math function*}}
test expr-old-34.8 {errors in math functions} -body {
list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
} -match glob -result {1 {too many arguments for math function*}}
test expr-old-34.9 {errors in math functions} {
list [catch {expr acos(-2.0)} msg] $msg $errorCode
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
test expr-old-34.10 {errors in math functions} {
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
expr {min(0)}
} -result 0
test expr-old-40.2 {min math function} -body {
expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
expr {min()}
| | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 |
expr {min(0)}
} -result 0
test expr-old-40.2 {min math function} -body {
expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
expr {min()}
} -returnCodes error -result {not enough arguments for math function "min"}
test expr-old-40.4 {min math function} -body {
expr {min(wide(-1) << 30, 4.5, -10)}
} -result [expr {wide(-1) << 30}]
test expr-old-40.5 {min math function} -body {
expr {min("a", 0)}
} -returnCodes error -match glob -result *
test expr-old-40.6 {min math function} -body {
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 |
expr {max(0)}
} -result 0
test expr-old-41.2 {max math function} -body {
expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
expr {max()}
| | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
expr {max(0)}
} -result 0
test expr-old-41.2 {max math function} -body {
expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
expr {max()}
} -returnCodes error -result {not enough arguments for math function "max"}
test expr-old-41.4 {max math function} -body {
expr {max(wide(1) << 30, 4.5, -10)}
} -result [expr {wide(1) << 30}]
test expr-old-41.5 {max math function} -body {
expr {max("a", 0)}
} -returnCodes error -match glob -result *
test expr-old-41.6 {max math function} -body {
|
| ︙ | ︙ |
Changes to tests/expr.test.
1 2 3 4 5 6 | # Commands covered: expr # # 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 |
# Commands covered: expr
#
# 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 © 1996-1997 Sun Microsystems, Inc.
# 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.
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]]
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
set ::errorInfo
} -match glob -result {too many arguments for math function*
while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
catch {expr sin()} msg
set ::errorInfo
| | | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 |
set ::errorInfo
} -match glob -result {too many arguments for math function*
while *ing
"expr sin(1,2,3)"}
test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body {
catch {expr sin()} msg
set ::errorInfo
} -match glob -result {not enough arguments for math function*
while *ing
"expr sin()"}
test expr-15.5 {CompileMathFuncCall: not enough arguments} -body {
catch {expr pow(1)} msg
set ::errorInfo
} -match glob -result {not enough arguments for math function*
while *ing
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
|
| ︙ | ︙ | |||
7247 7248 7249 7250 7251 7252 7253 |
string match {*no string representation*} [
::tcl::unsupported::representation $a]]
} {0 0 1 1}
foreach func {isfinite isinf isnan isnormal issubnormal} {
test expr-53.1.$func {float classification: basic arg handling} -body {
expr ${func}()
| | | 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 |
string match {*no string representation*} [
::tcl::unsupported::representation $a]]
} {0 0 1 1}
foreach func {isfinite isinf isnan isnormal issubnormal} {
test expr-53.1.$func {float classification: basic arg handling} -body {
expr ${func}()
} -returnCodes error -result "not enough arguments for math function \"$func\""
test expr-53.2.$func {float classification: basic arg handling} -body {
expr ${func}(1,2)
} -returnCodes error -result "too many arguments for math function \"$func\""
test expr-53.3.$func {float classification: basic arg handling} -body {
expr ${func}(true)
} -returnCodes error -result {expected number but got "true"}
test expr-53.4.$func {float classification: basic arg handling} -body {
|
| ︙ | ︙ | |||
7342 7343 7344 7345 7346 7347 7348 |
} -result {wrong # args: should be "fpclassify floatValue"}
test expr-59.12 {float classification: fpclassify} -returnCodes error -body {
fpclassify gorp
} -result {expected number but got "gorp"}
test expr-60.1 {float classification: basic arg handling} -body {
expr isunordered()
| | | | 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 |
} -result {wrong # args: should be "fpclassify floatValue"}
test expr-59.12 {float classification: fpclassify} -returnCodes error -body {
fpclassify gorp
} -result {expected number but got "gorp"}
test expr-60.1 {float classification: basic arg handling} -body {
expr isunordered()
} -returnCodes error -result {not enough arguments for math function "isunordered"}
test expr-60.2 {float classification: basic arg handling} -body {
expr isunordered(1)
} -returnCodes error -result {not enough arguments for math function "isunordered"}
test expr-60.3 {float classification: basic arg handling} -body {
expr {isunordered(1, 2, 3)}
} -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 {
|
| ︙ | ︙ | |||
7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 |
foreach v2 $values r2 $results {
test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" {
expr {isunordered($v1, $v2)}
} [expr {$r1 || $r2}]
}
}
unset -nocomplain values results ctr
# cleanup
unset -nocomplain a
unset -nocomplain min
unset -nocomplain max
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 |
foreach v2 $values r2 $results {
test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" {
expr {isunordered($v1, $v2)}
} [expr {$r1 || $r2}]
}
}
unset -nocomplain values results ctr
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
test expr-62.3 {TIP 582: comments} -setup {
set ctr 0
} -body {
expr {
# This is a demonstration of a comment
1 + 2 + 3
# and another comment
+ 4 + 5
# + [incr ctr]
+ [incr ctr]
}
} -result 16
# Buggy because line breaks aren't tracked inside expressions at all
test expr-62.4 {TIP 582: comments don't hide line breaks} -setup {
proc getline {} {
dict get [info frame -1] line
}
set base [getline]
} -constraints knownBug -body {
expr {
0
# a comment
+ [getline] - $base
}
} -cleanup {
rename getline ""
} -result 5
test expr-62.5 {TIP 582: comments don't splice tokens} {
set a False
expr {$a#don't splice
ne#don't splice
false}
} 1
test expr-62.6 {TIP 582: comments don't splice tokens} {
expr {0x2#don't splice
ne#don't splice
2}
} 1
test expr-62.7 {TIP 582: comments can go inside function calls} {
expr {max(1,# comment
2)}
} 2
test expr-62.8 {TIP 582: comments can go inside function calls} {
expr {max(1# comment
,2)}
} 2
test expr-62.9 {TIP 582: comments can go inside function calls} {
expr {max(# comment
1,2)}
} 2
test expr-62.10 {TIP 582: comments can go inside function calls} {
expr {max# comment
(1,2)}
} 2
# cleanup
unset -nocomplain a
unset -nocomplain min
unset -nocomplain max
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/fCmd.test.
1 2 3 4 5 6 | # This file tests the tclFCmd.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 41 42 43 44 45 46 47 48 49 50 51 52 |
# This file tests the tclFCmd.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.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1999 Scriptics Corporation.
#
# 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]]
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint winXP 0
testConstraint winLessThan10 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint reg 0
if {[testConstraint win]} {
catch {
# Is the registry extension already static to this shell?
try {
load {} Registry
set ::reglib {}
} on error {} {
# try the location given to use on the commandline to tcltest
::tcltest::loadTestedCommands
load $::reglib Registry
}
testConstraint reg 1
}
}
testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}]
set tmpspace /tmp;# default value
# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
testConstraint foundGroup [expr {![testConstraint unix]}]
if {[testConstraint unix]} {
catch {
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
}
}
# Also used in winFCmd...
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) >= 5.0} {
| > > > > | | | > > | 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 |
testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
}
}
# Also used in winFCmd...
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) >= 5.0} {
if {$::tcl_platform(osVersion) < 10.0} {
testConstraint winLessThan10 1
}
if {$::tcl_platform(osVersion) >= 6.0} {
testConstraint winVista 1
} else {
testConstraint win2000orXP 1
}
}
}
testConstraint darwin9 [expr {
[testConstraint unix]
&& $tcl_platform(os) eq "Darwin"
&& [package vsatisfies 1.$::tcl_platform(osVersion) 1.9]
}]
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
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
file mkdir td1
set x [list [file exists tf1] [file exists tf2] [file exists td1]]
file delete tf1 td1 tf2
lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
| | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
file mkdir td1
set x [list [file exists tf1] [file exists tf2] [file exists td1]]
file delete tf1 td1 tf2
lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
} -constraints {notRoot unixOrWin notWine} -body {
createfile tf1
createfile tf2
file mkdir td1
catch {file delete tf1 td1 $root tf2}
list [file exists tf1] [file exists tf2] [file exists td1]
} -cleanup {cleanup} -result {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
file mkdir td2
createfile [file join td2 tf1]
file rename -force td2 td1
file exists [file join td1 td2 tf1]
} -result 1
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup {
cleanup
| | | | | 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 |
file mkdir td2
createfile [file join td2 tf1]
file rename -force td2 td1
file exists [file join td1 td2 tf1]
} -result 1
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup {
cleanup
} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2]
createfile [file join td1 td2 tf1]
file mkdir td2
file rename -force td2 td1
} -returnCodes error -match glob -result \
[subst {error renaming "td2" to "[file join td1 td2]": file *}]
test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} -setup {
cleanup
} -constraints {notRoot notWine} -returnCodes error -body {
file rename -force $root tf1
} -result [subst {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}]
test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup {
cleanup
} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2]
createfile [file join td1 td2 tf1]
file mkdir td2
file rename -force td2 td1
} -returnCodes error -match glob -result \
[subst {error renaming "td2" to "[file join td1 td2]": file *}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} -setup {
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
file rename tf1 $tmpspace
glob -nocomplain tf* [file join $tmpspace tf*]
} -result [file join $tmpspace tf1]
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {xdev notRoot} -body {
file mkdir td1/td2/td3
| | | | | | | | | | | | 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 |
file rename tf1 $tmpspace
glob -nocomplain tf* [file join $tmpspace tf*]
} -result [file join $tmpspace tf1]
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {xdev notRoot} -body {
file mkdir td1/td2/td3
file attributes td1 -permissions 0
file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1 -permissions 0o755
cleanup
} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir ~/td1/td2
set td1name [file join [file dirname ~] [file tail ~] td1]
file attributes $td1name -permissions 0
file copy ~/td1 td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
file delete -force ~/td1
} -result {error copying "~/td1": permission denied}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td2
file mkdir ~/td1
set td1name [file join [file dirname ~] [file tail ~] td1]
file attributes $td1name -permissions 0
file copy td2 ~/td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
file delete -force ~/td1
} -result {error copying "td2" to "~/td1/td2": permission denied}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir ~/td1/td2
set td2name [file join [file dirname ~] [file tail ~] td1 td2]
file attributes $td2name -permissions 0
file copy ~/td1 td1
} -returnCodes error -cleanup {
file attributes $td2name -permissions 0o755
file delete -force ~/td1
} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {notRoot xdev} -returnCodes error -body {
file mkdir td1/td2/td3
file mkdir [file join $tmpspace td1]
createfile [file join $tmpspace td1 tf1]
file rename -force td1 $tmpspace
} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {notRoot xdev} -body {
file mkdir td1/td2/td3
file attributes td1/td2/td3 -permissions 0
file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1/td2/td3 -permissions 0o755
cleanup $tmpspace
} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": "td1/td2/td3": permission denied}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup {
cleanup $tmpspace
} -constraints {notRoot xdev} -body {
file mkdir td1/td2/td3
file rename td1 $tmpspace
|
| ︙ | ︙ | |||
807 808 809 810 811 812 813 |
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
} -cleanup {
cleanup
} -result {{td3 td4} 1 0}
test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
cleanup
| | | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 |
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
} -cleanup {
cleanup
} -result {{td3 td4} 1 0}
test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
cleanup
} -constraints {notRoot testchmod notWine} -body {
createfile tf1 tf1
createfile tf2 tf2
testchmod 0o444 tf2
file rename -force tf1 tf1
file rename -force tf2 tf2
list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} -result {tf1 tf2 1 0}
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
} -result {{td1 td2} 1 0}
test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
cleanup
| | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
} -result {{td1 td2} 1 0}
test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
cleanup
} -constraints {notRoot testchmod notWine} -body {
createfile tf1
createfile tf2
createfile tfs1
createfile tfs2
createfile tfs3
createfile tfs4
createfile tfd1
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 |
}
list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
[file writable [file join tdd2 tds2]] $w3 $w4
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
cleanup
| | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 |
}
list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
[file writable [file join tdd2 tds2]] $w3 $w4
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
cleanup
} -constraints {notRoot testchmod notWine} -body {
file mkdir tds1
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
if {!([testConstraint unix] || [testConstraint winVista])} {
testchmod 0o555 tds2
}
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
[catch {file rename td1 td2} msg] $msg
} -cleanup {
testchmod 0o755 [file join td2 td1]
} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup {
cleanup
| | | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 |
[catch {file rename td1 td2} msg] $msg
} -cleanup {
testchmod 0o755 [file join td2 td1]
} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup {
cleanup
} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2] [file join td2 td1 td4]
file rename -force td1 td2
} -returnCodes error -match glob -result \
[subst {error renaming "td1" to "[file join td2 td1]": file *}]
test fCmd-9.14 {file rename: comprehensive: dir into self} -setup {
cleanup
} -constraints {notRoot notWine} -body {
file mkdir td1
list [glob td*] [list [catch {file rename td1 td1} msg] $msg]
} -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]
test fCmd-9.14.1 {file rename: comprehensive: dir into self} -setup {
cleanup
} -constraints {notRoot} -body {
file mkdir td1
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 |
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
testchmod 0o755 td2
testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1]
test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
cleanup
| | | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
testchmod 0o755 td2
testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1]
test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
cleanup
} -constraints {notRoot testchmod notWine} -body {
createfile tf1
createfile tf2
createfile tfs1
createfile tfs2
createfile tfs3
createfile tfs4
createfile tfd1
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 |
file delete -force tfad
} -result {1}
test fCmd-12.8 {renamefile: generic error} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/dir
| | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
file delete -force tfad
} -result {1}
test fCmd-12.8 {renamefile: generic error} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/dir
file attributes tfa -permissions 0o555
catch {file rename tfa/dir tfa2}
} -cleanup {
catch {file attributes tfa -permissions 0o777}
file delete -force tfa
} -result {1}
test fCmd-12.9 {renamefile: moving a file across volumes} -setup {
cleanup $tmpspace
} -constraints {unix notRoot} -body {
set s [createfile tfa]
file rename tfa $tmpspace
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 |
} -cleanup {
file delete -force tfa tfa2
} -result {1 1}
test fCmd-14.8 {copyfile: copy directory failing} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa/dir/a/b/c
| | | | 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 |
} -cleanup {
file delete -force tfa tfa2
} -result {1 1}
test fCmd-14.8 {copyfile: copy directory failing} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa/dir/a/b/c
file attributes tfa/dir -permissions 0
catch {file copy tfa tfa2}
} -cleanup {
file attributes tfa/dir -permissions 0o777
file delete -force tfa tfa2
} -result {1}
#
# Coverage tests for TclMkdirCmd()
#
test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup {
|
| ︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 |
file delete tfa1 tfa2
} -result {1 1}
test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
createfile tfa/file
| | | | 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 |
file delete tfa1 tfa2
} -result {1 1}
test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
createfile tfa/file
file attributes tfa -permissions 0
catch {file mkdir tfa/file}
} -cleanup {
file attributes tfa -permissions 0o777
file delete -force tfa
} -result {1}
test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} -setup {
catch {file delete -force -- tfa}
} -constraints {notRoot} -body {
file mkdir tfa/a/b/c
file isdir tfa/a/b/c
|
| ︙ | ︙ | |||
1665 1666 1667 1668 1669 1670 1671 |
file delete -force tfa
} -result {1}
test fCmd-16.9 {error while deleting file} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
createfile tfa/a
| | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 |
file delete -force tfa
} -result {1}
test fCmd-16.9 {error while deleting file} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
createfile tfa/a
file attributes tfa -permissions 0o555
catch {file delete tfa/a}
#######
####### If any directory in a tree that is being removed does not have
####### write permission, the process will fail! This is also the case
####### with "rm -rf"
#######
} -cleanup {
file attributes tfa -permissions 0o777
file delete -force tfa
} -result {1}
test fCmd-16.10 {deleting multiple files} -constraints {notRoot} -setup {
catch {file delete -force -- tfa1 tfa2}
} -body {
createfile tfa1
createfile tfa2
|
| ︙ | ︙ | |||
1695 1696 1697 1698 1699 1700 1701 |
} -result {}
# More coverage tests for mkpath()
test fCmd-17.1 {mkdir stat failing on target but not ENOENT} -setup {
catch {file delete -force -- tfa1}
} -constraints {unix notRoot} -body {
file mkdir tfa1
| | | | 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
} -result {}
# More coverage tests for mkpath()
test fCmd-17.1 {mkdir stat failing on target but not ENOENT} -setup {
catch {file delete -force -- tfa1}
} -constraints {unix notRoot} -body {
file mkdir tfa1
file attributes tfa1 -permissions 0o555
catch {file mkdir tfa1/tfa2}
} -cleanup {
file attributes tfa1 -permissions 0o777
file delete -force tfa1
} -result {1}
test fCmd-17.2 {mkdir several levels deep - relative} -setup {
catch {file delete -force -- tfa}
} -constraints {notRoot} -body {
file mkdir tfa/a/b
file isdir tfa/a/b
|
| ︙ | ︙ | |||
1906 1907 1908 1909 1910 1911 1912 |
file exists tfa
} -result {0}
test fCmd-19.2 {rmdir error besides EEXIST} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/a
| | | | 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 |
file exists tfa
} -result {0}
test fCmd-19.2 {rmdir error besides EEXIST} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/a
file attributes tfa -permissions 0o555
catch {file delete tfa/a}
} -cleanup {
file attributes tfa -permissions 0o777
file delete -force tfa
} -result {1}
test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup {
catch {file delete -force -- tfa}
} -body {
file mkdir tfa
file mkdir tfa/a
|
| ︙ | ︙ | |||
1934 1935 1936 1937 1938 1939 1940 |
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#
test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/a
| | | | 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 |
# Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd
#
test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
file mkdir tfa/a
file attributes tfa/a -permissions 00000
catch {file delete -force tfa}
} -cleanup {
file attributes tfa/a -permissions 0o777
file delete -force tfa
} -result {1}
test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot} -body {
file mkdir tfa
for {set i 1} {$i <= 300} {incr i} {
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
test fCmd-28.7 {file link: source already exists} -setup {
cd [temporaryDirectory]
} -constraints {linkFile} -body {
file link abc.file abc2.file
} -returnCodes error -cleanup {
cd [workingDirectory]
} -result {could not create new link "abc.file": that path already exists}
| > | | > | | 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 |
test fCmd-28.7 {file link: source already exists} -setup {
cd [temporaryDirectory]
} -constraints {linkFile} -body {
file link abc.file abc2.file
} -returnCodes error -cleanup {
cd [workingDirectory]
} -result {could not create new link "abc.file": that path already exists}
# In Windows 10 developer mode, we _can_ create symbolic links to files!
test fCmd-28.8 {file link} -constraints {linkFile winLessThan10} -setup {
cd [temporaryDirectory]
} -body {
file link -symbolic abc.link abc.file
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -returnCodes error -result {could not create new link "abc.link" pointing to "abc.file": invalid argument}
test fCmd-28.9 {file link: success with file} -constraints {linkFile} -setup {
cd [temporaryDirectory]
file delete -force abc.link
} -body {
file link abc.link abc.file
} -cleanup {
cd [workingDirectory]
|
| ︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 |
file link doesnt/abc.link abc.dir
} -returnCodes error -cleanup {
cd [workingDirectory]
} -result {could not create new link "doesnt/abc.link": no such file or directory}
test fCmd-28.11 {file link: success with directory} -setup {
cd [temporaryDirectory]
file delete -force abc.link
| | | | 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 |
file link doesnt/abc.link abc.dir
} -returnCodes error -cleanup {
cd [workingDirectory]
} -result {could not create new link "doesnt/abc.link": no such file or directory}
test fCmd-28.11 {file link: success with directory} -setup {
cd [temporaryDirectory]
file delete -force abc.link
} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
} -cleanup {
cd [workingDirectory]
} -result abc.dir
test fCmd-28.12 {file link: cd into a link} -setup {
cd [temporaryDirectory]
file delete -force abc.link
} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
set orig [pwd]
cd abc.link
set dir [pwd]
cd ..
set up [pwd]
cd $orig
|
| ︙ | ︙ | |||
2431 2432 2433 2434 2435 2436 2437 |
} else {
return "ok"
}
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result ok
| | | 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 |
} else {
return "ok"
}
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result ok
test fCmd-28.13 {file link} -constraints {linkDirectory notWine} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
} -body {
# duplicate link throws error
file link abc.link abc.dir
} -returnCodes error -cleanup {
file delete -force abc.link
|
| ︙ | ︙ | |||
2465 2466 2467 2468 2469 2470 2471 |
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {directory abc.dir}
test fCmd-28.15.2 {file link: copies link not dir} -setup {
cd [temporaryDirectory]
file delete -force abc.link
| | | | | | | 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 |
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {directory abc.dir}
test fCmd-28.15.2 {file link: copies link not dir} -setup {
cd [temporaryDirectory]
file delete -force abc.link
} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
file copy abc.link abc2.link
list [file type abc2.link] [file tail [file link abc2.link]]
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {link abc.dir}
cd [temporaryDirectory]
file delete -force abc.link
file delete -force abc2.link
cd abc.dir
file delete -force abc.file
file delete -force abc2.file
cd ..
file copy abc.file abc.dir
file copy abc2.file abc.dir
cd [workingDirectory]
test fCmd-28.16 {file link: glob inside link} -setup {
cd [temporaryDirectory]
file delete -force abc.link
} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
lsort [glob -dir abc.link -tails *]
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {abc.file abc2.file}
test fCmd-28.17 {file link: glob -type l} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
} -constraints {linkDirectory notWine} -body {
glob -dir [pwd] -type l -tails abc*
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {abc.link}
test fCmd-28.18 {file link: glob -type d} -constraints {linkDirectory notWine} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
} -body {
lsort [glob -dir [pwd] -type d -tails abc*]
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result [lsort [list abc.link abc.dir abc2.dir]]
test fCmd-28.19 {file link: relative paths} -setup {
cd [temporaryDirectory]
} -constraints {win linkDirectory notWine} -body {
file mkdir d1/d2/d3
file link d1/l2 d1/d2
} -cleanup {
catch {file delete -force d1}
cd [workingDirectory]
} -result d1/d2
test fCmd-28.20 {file link: relative paths} -setup {
|
| ︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 |
test fCmd-30.1 {file writable on 'My Documents'} -setup {
# 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
| | > > | | 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 |
test fCmd-30.1 {file writable on 'My Documents'} -setup {
# 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
}
|
| ︙ | ︙ |
Changes to tests/fileName.test.
1 2 3 4 5 6 | # This file tests the filename manipulation routines. # # 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 41 |
# This file tests the filename manipulation routines.
#
# 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1999 Scriptics Corporation.
#
# 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 testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
if {$::tcl_platform(osVersion) < 5.0 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
testConstraint linkDirectory 0
}
testConstraint symbolicLinkFile 0
testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}]
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# This match compares the first two words of the result. If the wanted result
# is "equal", then this is successful if the words are equal. If the wanted
# result is "not equal", then this is successful if the words are different.
customMatch compareWords {apply {{a b} {
lassign $b w1 w2
expr {$a eq "equal" ? $w1 eq $w2 : $w1 ne $w2}
}}}
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
| | | | | | | 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 |
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.17.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.17.2 {Tcl_GlobCmd} -setup {
set dir [pwd]
} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
lsort [glob -directory $globname -join * b1]
} -cleanup {
cd $dir
file delete [file join $globname link]
} -result [list [file join $globname a1 b1] \
[file join $globname link b1]]
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} -setup {
set dir [pwd]
} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
lsort [glob -directory $globname -type d *]
} -cleanup {
cd $dir
file delete [file join $globname link]
} -result [list [file join $globname a1] \
[file join $globname a2] \
[file join $globname a3] \
[file join $globname link]]
# Make sure the bugfix isn't too simple. We don't want to break 'glob -type l'
test filename-11.17.4 {Tcl_GlobCmd} -setup {
set dir [pwd]
} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
lsort [glob -directory $globname -type l *]
} -cleanup {
cd $dir
file delete [file join $globname link]
} -result [list [file join $globname link]]
test filename-11.17.5 {Tcl_GlobCmd} {
lsort [glob -directory $globname -tails *.c]
} [lsort [list "weird name.c" x,z1.c x1.c y1.c z1.c]]
test filename-11.17.6 {Tcl_GlobCmd} {
lsort [glob -directory $globname -tails *.c *.c]
} [lsort [concat [list "weird name.c" x,z1.c x1.c y1.c z1.c] \
[list "weird name.c" x,z1.c x1.c y1.c z1.c]]]
test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} -setup {
set dir [pwd]
} -constraints {linkDirectory notWine} -body {
cd $globname
file mkdir nonexistent
file link -symbolic link nonexistent
file delete nonexistent
cd $dir
lsort [glob -nocomplain -directory $globname -type l *]
} -cleanup {
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
| | | | | 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 |
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.18.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.19 {Tcl_GlobCmd} {unix} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.19.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.20 {Tcl_GlobCmd} notWine {
lsort [glob -type d -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
test filename-11.21 {Tcl_GlobCmd} {
lsort [glob -type d -path $globname *]
} [list $globname]
|
| ︙ | ︙ | |||
929 930 931 932 933 934 935 |
lsort [glob -dir $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
| | | | | | | | 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 |
lsort [glob -dir $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.22.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -dir $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.23 {Tcl_GlobCmd} {unix} {
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.23.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.24 {Tcl_GlobCmd} {unix} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.24.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.25 {Tcl_GlobCmd} notWine {
lsort [glob -type d -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
test filename-11.25.1 {Tcl_GlobCmd} notWine {
lsort [glob -type {d r} -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
test filename-11.25.2 {Tcl_GlobCmd} notWine {
lsort [glob -type {d r w} -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
test filename-11.26 {Tcl_GlobCmd} {
glob -type d -path $globname *
} [list $globname]
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 |
} -result {bad argument to "-types": abcde}
test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -path foo -join * *
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
test filename-12.1 {simple globbing} {unixOrWin} {
| > > > > > > | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 |
} -result {bad argument to "-types": abcde}
test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
glob -types abcde -path foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body {
glob -path hello -path salut *
} -result {"-path" may only be used once}
test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body {
glob -dir hello -dir salut *
} -result {"-directory" may only be used once}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
test filename-12.1 {simple globbing} {unixOrWin} {
|
| ︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 |
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext
} -result {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unix} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
| | | | | 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 |
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext
} -result {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unix} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {win notWine} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin notWine} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*/*]
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin notWine} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
global env
set temp $env(HOME)
} -body {
set env(HOME) [file join $env(HOME) globTest]
|
| ︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 |
test filename-14.25 {type specific globbing} {unix} {
lsort [glob -dir globTest -types f *]
} [lsort [list \
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
| | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 |
test filename-14.25 {type specific globbing} {unix} {
lsort [glob -dir globTest -types f *]
} [lsort [list \
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-14.25.1 {type specific globbing} {win notWine} {
lsort [glob -dir globTest -types f *]
} [lsort [list \
[file join $globname .1]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
|
| ︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 | unset globname # The following tests are only valid for Unix systems. On some systems, like # AFS, "000" protection doesn't prevent access by owner, so the following test # is not portable. | | | | 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 |
unset globname
# The following tests are only valid for Unix systems. On some systems, like
# AFS, "000" protection doesn't prevent access by owner, so the following test
# is not portable.
catch {file attributes globTest/a1 -permissions 0}
test filename-15.1 {unix specific globbing} {unix nonPortable} {
string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unix nonPortable} {
glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
{unix nonPortable} {
# test fails because if an error occurs, the interp's result is reset...
glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
catch {file attributes globTest/a1 -permissions 0o755}
test filename-15.4 {unix specific no complain: no errors, good result} \
{unix nonPortable} {
# test fails because if an error occurs, the interp's result is reset...
# or you don't run at scriptics where the outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
test filename-15.4.1 {no complain: errors, sequencing} {
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
1 2 3 4 5 6 | # This file tests the filesystem and vfs internals. # # 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 41 42 43 44 45 46 47 48 49 |
# This file tests the filesystem and vfs internals.
#
# 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 © 2002 Vincent Darley.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval ::tcl::test::fileSystem {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.dir linkinside.file]
}
testConstraint loaddll 0
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::ddever [package require dde]
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
makeDirectory dir.dir
makeDirectory [file join dir.dir dirinside.dir]
makeFile "test file in directory" [file join dir.dir inside.file]
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
} 1
test filesystem-1.37 {file normalisation with '/./'} -body {
set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
file norm $fname
} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
test filesystem-1.38 {file normalisation with volume relative} -setup {
set dir [pwd]
| | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
} 1
test filesystem-1.37 {file normalisation with '/./'} -body {
set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
file norm $fname
} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
test filesystem-1.38 {file normalisation with volume relative} -setup {
set dir [pwd]
} -constraints {win moreThanOneDrive notInCIenv} -body {
set path "[string range [lindex $drives 0] 0 1]foo"
cd [lindex $drives 1]
file norm $path
} -cleanup {
cd $dir
} -result "[lindex $drives 0]foo"
test filesystem-1.39 {file normalisation with volume relative} -setup {
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 |
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::ddelib]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
| | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
test filesystem-7.1.1 {load from vfs} -setup {
set dir [pwd]
} -constraints {win testsimplefilesystem loaddll} -body {
# This may cause a crash on exit
cd [file dirname $::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 {
|
| ︙ | ︙ | |||
685 686 687 688 689 690 691 |
puts -nonewline $fout "1234567890"
close $fout
testsimplefilesystem 1
} -constraints {testsimplefilesystem unix} -body {
# First copy should succeed
set res [catch {file copy simplefs:/simplefile file2} err]
lappend res $err
| | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
puts -nonewline $fout "1234567890"
close $fout
testsimplefilesystem 1
} -constraints {testsimplefilesystem unix} -body {
# First copy should succeed
set res [catch {file copy simplefs:/simplefile file2} err]
lappend res $err
file attributes file2 -permissions 0
# Second copy should fail (no -force)
lappend res [catch {file copy simplefs:/simplefile file2} err]
lappend res $err
# Third copy should succeed (-force)
lappend res [catch {file copy -force simplefs:/simplefile file2} err]
lappend res $err
lappend res [file exists file2]
|
| ︙ | ︙ |
Changes to tests/fileSystemEncoding.test.
1 2 | #! /usr/bin/env tclsh | | > > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#! /usr/bin/env tclsh
# Copyright © 2019 Poor Yorick
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
}
namespace eval ::tcl::test::fileSystemEncoding {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
variable fname1 \u767b\u9e1b\u9d72\u6a13
proc autopath {} {
global auto_path
set scriptpath [info script]
set scriptpathnorm [file dirname [file normalize $scriptpath/...]]
|
| ︙ | ︙ |
Changes to tests/for-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: for, continue, break # # This file contains the original set of tests for Tcl's for command. # Since the for command is now compiled, a new set of tests covering # the new implementation is in the file "for.test". 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 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 |
# Commands covered: for, continue, break
#
# This file contains the original set of tests for Tcl's for command.
# Since the for command is now compiled, a new set of tests covering
# the new implementation is in the file "for.test". 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.
#
# 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::*
}
# Check "for" and its use of continue and break.
catch {unset a i}
test for-old-1.1 {for tests} {
set a {}
for {set i 1} {$i<6} {incr i} {
set a [concat $a $i]
}
set a
} {1 2 3 4 5}
test for-old-1.2 {for tests} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==4} continue
set a [concat $a $i]
}
set a
} {1 2 3 5}
test for-old-1.3 {for tests} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==4} break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1
test for-old-1.5 {for tests} {
catch {for 1 2 3} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
test for-old-1.7 {for tests} {
catch {for 1 2 3 4 5} msg
set msg
} {wrong # args: should be "for start test next command"}
test for-old-1.8 {for tests} {
set a {xyz}
for {set i 1} {$i<6} {incr i} {}
set a
} xyz
test for-old-1.9 {for tests} {
set a {}
for {set i 1} {$i<6} {incr i; if {$i==4} break} {
set a [concat $a $i]
}
set a
} {1 2 3}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/for.test.
1 2 3 4 5 6 | # Commands covered: for, continue, break # # 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 |
# Commands covered: for, continue, break
#
# 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 © 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc meminfo {} {lindex [split [memory info] "\n"] 3 3}
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
set a {}
| | | | | | | | | 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 |
set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}
catch {unset a}
test for-1.9 {TclCompileForCmd: simple command body} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==4} break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-1.10 {TclCompileForCmd: command body in quotes} {
set a {}
for {set i 1} {$i<6} {incr i} "append a x"
set a
} {xxxxx}
test for-1.11 {TclCompileForCmd: computed command body} {
catch {unset x1}
catch {unset bb}
catch {unset x2}
set x1 {append a x1; }
set bb {break}
set x2 {; append a x2}
set a {}
for {set i 1} {$i<6} {incr i} $x1$bb$x2
set a
} {x1}
test for-1.12 {TclCompileForCmd: error in "next" command} -body {
catch {for {set i 0} {$i < 5} {set} {format $i}} msg
set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}
test for-1.13 {TclCompileForCmd: long command body} {
set a {}
for {set i 1} {$i<6} {incr i} {
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
set a
} {1 2 3}
test for-1.14 {TclCompileForCmd: for command result} {
set a [for {set i 0} {$i < 5} {incr i} {}]
set a
} {}
test for-1.15 {TclCompileForCmd: for command result} {
| | | | | | | | | 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 |
set a
} {1 2 3}
test for-1.14 {TclCompileForCmd: for command result} {
set a [for {set i 0} {$i < 5} {incr i} {}]
set a
} {}
test for-1.15 {TclCompileForCmd: for command result} {
set a [for {set i 0} {$i < 5} {incr i} {if {$i==3} break}]
set a
} {}
# Check "for" and "continue".
test for-2.1 {TclCompileContinueCmd: arguments after "continue"} {
catch {continue foo} msg
set msg
} {wrong # args: should be "continue"}
test for-2.2 {TclCompileContinueCmd: continue result} {
catch continue
} 4
test for-2.3 {continue tests} {
set a {}
for {set i 1} {$i <= 4} {incr i} {
if {$i == 2} continue
set a [concat $a $i]
}
set a
} {1 3 4}
test for-2.4 {continue tests} {
set a {}
for {set i 1} {$i <= 4} {incr i} {
if {$i != 2} continue
set a [concat $a $i]
}
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
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
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 {}
| | | | | | | 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 |
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
if {$i==5} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i==4} break
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
if {[regexp {^[ ]*$} $line] || [regexp {^--+} $line]} {
set inheaders 0
}
if {[regexp -nocase {^x-mailer:} $line]} {
continue
}
}
| | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
if {[regexp {^[ ]*$} $line] || [regexp {^--+} $line]} {
set inheaders 0
}
if {[regexp -nocase {^x-mailer:} $line]} {
continue
}
}
if {$inheaders} {
set limit 55
} else {
set limit 55
# Decide whether or not to break the body line
if {$plen > 0} {
if {[string first {> } $line] == 0} {
# This is quoted text from previous message, don't reformat
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
append result $line $NL
if {[string length $F1] == 0} {
set F1 -1
}
continue
}
}
| | | | | 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 |
append result $line $NL
if {[string length $F1] == 0} {
set F1 -1
}
continue
}
}
set climit [expr {$limit-1}]
set cutoff 50
set continuation 0
while {[string length $line] > $limit} {
for {set c [expr {$limit-1}]} {$c >= $cutoff} {incr c -1} {
set char [string index $line $c]
if {$char == " " || $char == "\t"} {
break
}
if {$char == ">"} { ;# Hack for enriched formatting
break
}
}
if {$c < $cutoff} {
if {! $inheaders} {
set c [expr {$limit-1}]
} else {
set c [string length $line]
}
}
set newline [string trimright [string range $line 0 $c]]
if {! $continuation} {
append result $newline $NL
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 |
}
# 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
| | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 |
}
# 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
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 |
"set"
("for" body line 1)
invoked from within
"$z {set i 0} {$i < 5} {incr i} {set}"}
test for-6.10 {Tcl_ForObjCmd: simple command body} {
set z for
set a {}
| | | | | | | | | 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 |
"set"
("for" body line 1)
invoked from within
"$z {set i 0} {$i < 5} {incr i} {set}"}
test for-6.10 {Tcl_ForObjCmd: simple command body} {
set z for
set a {}
$z {set i 1} {$i<6} {incr i} {
if {$i==4} break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-6.11 {Tcl_ForObjCmd: command body in quotes} {
set z for
set a {}
$z {set i 1} {$i<6} {incr i} "append a x"
set a
} {xxxxx}
test for-6.12 {Tcl_ForObjCmd: computed command body} {
set z for
catch {unset x1}
catch {unset bb}
catch {unset x2}
set x1 {append a x1; }
set bb {break}
set x2 {; append a x2}
set a {}
$z {set i 1} {$i<6} {incr i} $x1$bb$x2
set a
} {x1}
test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body {
set z for
catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
set ::errorInfo
} -match glob -result {wrong # args: should be "set varName ?newValue?"
while *ing
"set"
("for" loop-end command)
invoked from within
"$z {set i 0} {$i < 5} {set} {set j 4}"}
test for-6.14 {Tcl_ForObjCmd: long command body} {
set z for
set a {}
$z {set i 1} {$i<6} {incr i} {
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ |
Changes to tests/foreach.test.
1 2 3 4 5 6 | # Commands covered: foreach, continue, break # # 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 |
# Commands covered: foreach, continue, break
#
# 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-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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset a}
catch {unset x}
# Basic "foreach" operation.
|
| ︙ | ︙ |
Changes to tests/format.test.
1 2 3 4 5 6 | # Commands covered: format # # 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 |
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1998 Sun Microsystems, Inc.
#
# 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::*
}
# %u output depends on word length, so this test is not portable.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
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 {![info exists ::env(CI_BUILD_WITH_MSVC)]}]
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}
|
| ︙ | ︙ |
Changes to tests/get.test.
1 2 3 4 5 6 | # Commands covered: none # # This file contains a collection of tests for the procedures in the # file tclGet.c. 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 |
# Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# 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.
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 testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
} {44 44 44 44 54 51 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
} {44 44 44 44 54 51 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
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 " 0x_a " " 0_07 " " 0o_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } {
catch {testgetint $x} x
set x
}
} {0 10 2 33 1423324 10 7 8 {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"}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/history.test.
1 2 3 4 5 6 | # Commands covered: history # # 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 |
# Commands covered: history
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# The history command might be autoloaded...
if {[catch {history}]} {
testConstraint history 0
} else {
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
# "history event"
test history-1.1 {event option} history {history event -1} \
{set b [format {A test %s} string]}
test history-1.2 {event option} history {history event $num} \
{set a 12345}
| | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
# "history event"
test history-1.1 {event option} history {history event -1} \
{set b [format {A test %s} string]}
test history-1.2 {event option} history {history event $num} \
{set a 12345}
test history-1.3 {event option} history {history event [expr {$num+2}]} \
{Another test}
test history-1.4 {event option} history {history event set} \
{set b [format {A test %s} string]}
test history-1.5 {event option} history {history e "* a*"} \
{set a 12345}
test history-1.6 {event option} history {catch {history event *gorp} msg} 1
test history-1.7 {event option} history {
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
history add set\ c\ {a\nb\nc}
}
test history-5.1 {info option} history {history info} [format {%6d set a {b
c d e}
%6d set b 1234
%6d set c {a
b
| | | | | > > | 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 |
history add set\ c\ {a\nb\nc}
}
test history-5.1 {info option} history {history info} [format {%6d set a {b
c d e}
%6d set b 1234
%6d set c {a
b
c}} $num [expr {$num+1}] [expr {$num+2}]]
test history-5.2 {info option} history {history i 2} [format {%6d set b 1234
%6d set c {a
b
c}} [expr {$num+1}] [expr {$num+2}]]
test history-5.3 {info option} history {catch {history i 2 3}} 1
test history-5.4 {info option} history {
catch {history i 2 3} msg
set msg
} {wrong # args: should be "history info ?count?"}
test history-5.5 {info option} history {history} [format {%6d set a {b
c d e}
%6d set b 1234
%6d set c {a
b
c}} $num [expr {$num+1}] [expr {$num+2}]]
# "history keep"
if {[testConstraint history]} {
history add "foo1"
history add "foo2"
history add "foo3"
history keep 2
}
test history-6.1 {keep option} history {
history event [expr {[history n]-1}]
} foo3
test history-6.2 {keep option} history {history event -1} foo2
test history-6.3 {keep option} history {catch {history event -3}} 1
test history-6.4 {keep option} history {
catch {history event -3} msg
set msg
} {event "-3" is too far in the past}
if {[testConstraint history]} {
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
if {[testConstraint history]} {
set num [history n]
history add "Testing"
history add "Testing2"
}
test history-7.1 {nextid option} history {history event} "Testing"
| | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
if {[testConstraint history]} {
set num [history n]
history add "Testing"
history add "Testing2"
}
test history-7.1 {nextid option} history {history event} "Testing"
test history-7.2 {nextid option} history {history next} [expr {$num+2}]
test history-7.3 {nextid option} history {catch {history nextid garbage}} 1
test history-7.4 {nextid option} history {
catch {history nextid garbage} msg
set msg
} {wrong # args: should be "history nextid"}
# "history clear"
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
# Ignore the references due to calling this procedure
return [expr {$rc - 3}]
}
}
} -body {
histtest eval {
# A fresh object, refcount 1 from the variable we write it to
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
# Ignore the references due to calling this procedure
return [expr {$rc - 3}]
}
}
} -body {
histtest eval {
# A fresh object, refcount 1 from the variable we write it to
set obj [expr {rand()}]
set baseline [refcount $obj]
lappend result [refcount $obj]
history add [list list $obj]
lappend result [refcount $obj]
history clear
lappend result [refcount $obj]
}
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
# Ignore the references due to calling this procedure
return [expr {$rc - 3}]
}
}
} -body {
histtest eval {
# A fresh object, refcount 1 from the variable we write it to
| | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
# Ignore the references due to calling this procedure
return [expr {$rc - 3}]
}
}
} -body {
histtest eval {
# A fresh object, refcount 1 from the variable we write it to
set obj [expr {rand()}]
set baseline [refcount $obj]
lappend result [refcount $obj]
history add [list list $obj]
lappend result [refcount $obj]
rename history {}
lappend result [refcount $obj]
}
|
| ︙ | ︙ |
Changes to tests/http.test.
1 2 3 4 5 6 | # Commands covered: http::config, http::geturl, http::wait, http::reset # # This file contains a collection of tests for the http script library. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # | | | | > | | > | | | > | < < < < | 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 |
# Commands covered: http::config, http::geturl, http::wait, http::reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
#
# 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::*
}
if {[catch {package require http 2} version]} {
if {[info exists http2]} {
catch {puts "Cannot load http 2.* package"}
return
} else {
catch {puts "Running http 2.* tests in child interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
$interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
return
}
}
proc bgerror {args} {
global errorInfo
puts stderr "http.test bgerror"
puts stderr [join $args]
puts stderr $errorInfo
}
# Do not use [info hostname].
# Name resolution is often a problem on OSX; not focus of HTTP package anyway.
# Also a problem on other platforms for http-4.14 (test with bad port number).
set HOST localhost
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
# Ensure httpd file exists
set origFile [file join [pwd] [file dirname [info script]] httpd]
set httpdFile [file join [temporaryDirectory] httpd_[pid]]
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
test http-3.1 {http::geturl} -returnCodes error -body {
http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //${::HOST}:$port
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
test http-3.1 {http::geturl} -returnCodes error -body {
http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //${::HOST}:$port
set badurl //${::HOST}:[expr {$port+1}]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
# Bug 838e99a76d
test http-3.33 {http::geturl application/xml is text} -body {
set token [http::geturl "$xmlurl"]
scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
} -cleanup {
catch { http::cleanup $token }
} -result {test 4660 /test}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
| > > > | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
# Bug 838e99a76d
test http-3.33 {http::geturl application/xml is text} -body {
set token [http::geturl "$xmlurl"]
scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
} -cleanup {
catch { http::cleanup $token }
} -result {test 4660 /test}
test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body {
http::geturl http://test/t -headers NoDict
} -result {Bad value for -headers (NoDict), must be dict}
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
array set meta $data(meta)
expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/http11.test.
1 2 3 4 5 6 7 8 9 | # http11.test -- -*- tcl-*- # # Test HTTP/1.1 features. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # 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 |
# http11.test -- -*- tcl-*-
#
# Test HTTP/1.1 features.
#
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.9
# 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
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
return [dict get $meta $key]
} else {
return ""
}
}
return $meta
}
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"
| > > > > > > > > > > > > > > | 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 |
return [dict get $meta $key]
} else {
return ""
}
}
return $meta
}
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"
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
list [http::status $tok] [http::code $tok] [check_crc $tok] \
[meta $tok content-encoding] [meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
# -------------------------------------------------------------------------
test http11-2.0 "-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]
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
list [http::status $tok] [http::code $tok] [check_crc $tok] \
[meta $tok content-encoding] [meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
test http11-1.13 "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 {
http::cleanup $tok
http::cleanup $toj
halt_httpd
http::config -zip $zipTmp
} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive}
# -------------------------------------------------------------------------
proc progress {var token total current} {
upvar #0 $var log
set log [list $current $total]
return
}
proc progressPause {var token total current} {
upvar #0 $var log
set log [list $current $total]
after 100 set ::WaitHere 0
vwait ::WaitHere
return
}
test http11-2.0 "-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]
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
[meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
test http11-2.5 "-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 \
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
[meta $tok transfer-encoding]
} -cleanup {
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 "-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 {
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 "-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 {
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 "-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 \
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 520 521 522 523 524 525 526 |
proc handler {var sock token} {
upvar #0 $var data
set chunk [read $sock]
append data $chunk
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
return [string length $chunk]
}
test http11-3.0 "-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]]]
| > > > > > > > > > > | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
proc handler {var sock token} {
upvar #0 $var data
set chunk [read $sock]
append data $chunk
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
return [string length $chunk]
}
proc handlerPause {var sock token} {
upvar #0 $var data
set chunk [read $sock]
append data $chunk
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
after 100 set ::WaitHere 0
vwait ::WaitHere
return [string length $chunk]
}
test http11-3.0 "-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]]]
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
[expr {[file size testdoc.html]-[string length $testdata]}]
} -cleanup {
http::cleanup $tok
unset -nocomplain testdata
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
test http11-4.0 "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
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
[expr {[file size testdoc.html]-[string length $testdata]}]
} -cleanup {
http::cleanup $tok
unset -nocomplain testdata
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
# http11-3.4
# This test is a blatant attempt to confuse the client by instructing the server
# to send neither "Connection: close" nor "Content-Length" when in non-chunked
# mode.
# The client has no way to know the response-body is complete unless the
# server signals this by closing the connection.
# In an HTTP/1.1 response the absence of "Connection: close" means
# "Connection: keep-alive", i.e. the server will keep the connection
# 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 "-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 {
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 "-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 {
http::cleanup $tok
unset -nocomplain testdata ::WaitHere
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
test http11-3.6 "-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 {
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 "-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 {
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 "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 {
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 "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 {
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 "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
|
| ︙ | ︙ |
Changes to tests/httpPipeline.test.
1 2 3 4 5 6 7 8 9 10 | # httpPipeline.test # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> # # 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 |
# httpPipeline.test
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.9
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]
# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -
|
| ︙ | ︙ |
Changes to tests/httpTest.tcl.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
# - 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]
| | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
# - 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
}
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
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
| | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
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]
}
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
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]]
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
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} {
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
# were scheduled (by A) but not completed (by F). Pass each segment to
# MostAnalysis for processing.
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
variable testOptions
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
| | | | | 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 |
# were scheduled (by A) but not completed (by F). Pass each segment to
# 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 {
|
| ︙ | ︙ |
Changes to tests/httpcookie.test.
1 2 3 4 5 6 | # Commands covered: http::cookiejar # # This file contains a collection of tests for the cookiejar package. # 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 |
# Commands covered: http::cookiejar
#
# This file contains a collection of tests for the cookiejar package.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 2014 Donal K. Fellows.
#
# 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
testConstraint notMacCI [expr {![info exists ::env(MAC_CI)]}]
testConstraint sqlite3 [expr {[testConstraint notMacCI] && ![catch {
package require sqlite3
}]}]
testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
package require cookiejar
}]}]
set COOKIEJAR_VERSION 0.2.0
|
| ︙ | ︙ |
Changes to tests/httpd.
1 2 3 4 | # -*- tcl -*- # # The httpd_ procedures implement a stub http server. # | | | | | > | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# -*- tcl -*-
#
# The httpd_ procedures implement a stub http server.
#
# Copyright © 1997-1998 Sun Microsystems, Inc.
# Copyright © 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#set httpLog 1
# Do not use [info hostname].
# Name resolution is often a problem on OSX; not focus of HTTP package anyway.
# Also a problem on other platforms for http-4.14 (test with bad port number).
set HOST localhost
proc httpd_init {{port 8015}} {
set s [socket -server httpdAccept $port]
# Save the actual port number in a global variable.
# This is important when we're called with port 0
# for picking an unused port at random.
set ::port [lindex [chan configure $s -sockname] 2]
|
| ︙ | ︙ |
Changes to tests/httpd11.tcl.
1 2 3 4 5 6 7 8 9 10 | # httpd11.tcl -- -*- tcl -*- # # A simple httpd for testing HTTP/1.1 client features. # Not suitable for use on a internet connected port. # # Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net> # # 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 |
# httpd11.tcl -- -*- tcl -*-
#
# A simple httpd for testing HTTP/1.1 client features.
# Not suitable for use on a internet connected port.
#
# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# 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
}
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
}
}
set transfer chunked
} else {
set close 1
}
foreach pair [split $query &] {
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
switch -exact -- $key {
close {set close 1 ; set transfer 0}
transfer {set transfer $val}
content-type {set type $val}
}
}
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]]
}
| > > > > > | | > > > > | 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 |
}
}
set transfer chunked
} else {
set close 1
}
set nosendclose 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}
}
}
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 ""
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
proc Accept {chan addr port} {
coroutine client$chan Service $chan $addr $port
return
}
proc Control {chan} {
| | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
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 {}
}
|
| ︙ | ︙ |
Changes to tests/if-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: if # # This file contains the original set of tests for Tcl's if command. # Since the if command is now compiled, a new set of tests covering # the new implementation is in the file "if.test". 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 |
# Commands covered: if
#
# This file contains the original set of tests for Tcl's if command.
# Since the if command is now compiled, a new set of tests covering
# the new implementation is in the file "if.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# 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::*
}
test if-old-1.1 {taking proper branch} {
set a {}
if 0 {set a 1} else {set a 2}
set a
|
| ︙ | ︙ |
Changes to tests/if.test.
1 2 3 4 5 6 | # Commands covered: if # # 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 |
# Commands covered: if
#
# 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 © 1996 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Basic "if" operation.
catch {unset a}
test if-1.1 {TclCompileIfCmd: missing if/elseif test} -body {
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
}
return $a
} -cleanup {
unset a
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
} elseif 1<2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 6
}
return $a
} -cleanup {
unset a
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
} elseif 1==2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 6
} else {
set a 7
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 8
while {$a != "xxx"} {
break;
while {$i >= 0} {
if {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
set i $i
set i [lindex $s $i]
}
if {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 9
}
return $a
} -cleanup {
unset a
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
}
return $a
} -cleanup {
unset a z
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
835 836 837 838 839 840 841 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
} elseif 1<2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 6
}
return $a
} -cleanup {
unset a z
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 2
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
994 995 996 997 998 999 1000 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 3
} elseif 1==2 then { #; this if arm should be taken
set a 4
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 5
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 6
} else {
set a 7
while {$a != "xxx"} {
break;
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 8
while {$a != "xxx"} {
break;
while {$i >= 0} {
$z {[string compare $a "bar"] < 0} {
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
| | | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
set i $i
set i [lindex $s $i]
}
$z {[string compare $a "bar"] < 0} {
set i $i
set i [lindex $s $i]
}
incr i -1
}
}
set a 9
}
return $a
} -cleanup {
unset a z
|
| ︙ | ︙ |
Changes to tests/incr-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: incr # # This file contains the original set of tests for Tcl's incr command. # Since the incr command is now compiled, a new set of tests covering # the new implementation is in the file "incr.test". 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 |
# Commands covered: incr
#
# This file contains the original set of tests for Tcl's incr command.
# Since the incr command is now compiled, a new set of tests covering
# the new implementation is in the file "incr.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# 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 {unset x}
test incr-old-1.1 {basic incr operation} {
set x 23
|
| ︙ | ︙ |
Changes to tests/incr.test.
1 2 3 4 5 6 | # Commands covered: incr # # 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 |
# Commands covered: incr
#
# 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 © 1996 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain x i
proc readonly varName {
upvar 1 $varName var
trace add variable var write \
|
| ︙ | ︙ |
Changes to tests/indexObj.test.
1 2 3 4 | # This file is a Tcl script to test out the the procedures in file # tkIndexObj.c, which implement indexed table lookups. The tests here are # organized in the standard fashion for Tcl tests. # | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 testindexobj [llength [info commands testindexobj]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
testindexobj 1 1 xyz abc def xyz alm
} {2}
|
| ︙ | ︙ |
Changes to tests/info.test.
1 2 3 4 5 6 7 | # -*- tcl -*- # Commands covered: info # # 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 |
# -*- tcl -*-
# Commands covered: info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2006 ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# DO NOT DELETE THIS LINE
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 zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 |
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} {
| | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
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}}}}}}
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
}
} -body {
info cmdtype ::testinfocmdtype::bar
} -cleanup {
rename ::testinfocmdtype::bar {}
namespace delete ::testinfocmdtype::foo
} -result import
| | | | | | | | 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
}
} -body {
info cmdtype ::testinfocmdtype::bar
} -cleanup {
rename ::testinfocmdtype::bar {}
namespace delete ::testinfocmdtype::foo
} -result import
test info-40.10 {info cmdtype: interps} -setup {
apply {i {
rename $i ::testinfocmdtype::child
variable ::testinfocmdtype::child $i
}} [interp create]
} -body {
info cmdtype ::testinfocmdtype::child
} -cleanup {
interp delete $::testinfocmdtype::child
} -result interp
test info-40.11 {info cmdtype: objects} -setup {
apply {{} {
oo::object create obj
} ::testinfocmdtype}
} -body {
info cmdtype ::testinfocmdtype::obj
} -cleanup {
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 |
}
} -cleanup {
namespace eval ::testinfocmdtype {
catch {rename foo {}}
catch {rename bar {}}
}
} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
| | | | | | 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 |
}
} -cleanup {
namespace eval ::testinfocmdtype {
catch {rename foo {}}
catch {rename bar {}}
}
} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
test info-40.17 {info cmdtype: aliases in child interpreters} -setup {
set i [interp create]
} -body {
$i alias foo gorp
$i eval {
info cmdtype foo
}
} -cleanup {
interp delete $i
} -result alias
test info-40.18 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe alias foo gorp
$safe eval {
info cmdtype foo
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.19 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
set inner [interp create [list $safe bar]]
interp alias $inner foo $safe gorp
$safe eval {
bar eval {
info cmdtype foo
}
}
} -returnCodes error -cleanup {
interp delete $safe
} -result {not allowed to invoke subcommand cmdtype of info}
test info-40.20 {info cmdtype: aliases in child interpreters} -setup {
set safe [interp create -safe]
} -body {
$safe eval {
interp alias {} foo {} gorp
info cmdtype foo
}
} -returnCodes error -cleanup {
|
| ︙ | ︙ |
Changes to tests/init.test.
1 2 3 4 5 6 | # Functionality covered: this file contains a collection of tests for the auto # loading and namespaces. # # 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 |
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
interp create child
} -body {
child eval {
list [set v [info exists ::errorInfo]] \
[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
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
test init-1.7 {auto_qualify - multiples colons 1} {
auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
auto_qualify :::foo ::bar
} foo
| | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
test init-1.7 {auto_qualify - multiples colons 1} {
auto_qualify :::foo::::bar ::blue
} ::foo::bar
test init-1.8 {auto_qualify - multiple colons 2} {
auto_qualify :::foo ::bar
} foo
# We use a child interp and auto_reset and double the tests because there is 2
# places where auto_loading occur (before loading the indexes files and after)
set testInterp [interp create]
tcltest::loadIntoChildInterpreter $testInterp {*}$argv
interp eval $testInterp {
namespace import -force ::tcltest::*
customMatch pairwise {apply {{mode pair} {
if {[llength $pair] != 2} {error "need a pair of values to check"}
string $mode [lindex $pair 0] [lindex $pair 1]
}}}
|
| ︙ | ︙ |
Changes to tests/internals.tcl.
1 2 3 4 5 6 | # This file contains internal facilities for Tcl tests. # # Source this file in the related tests to include from tcl-tests: # # source [file join [file dirname [info script]] internals.tcl] # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# This file contains internal facilities for Tcl tests.
#
# Source this file in the related tests to include from tcl-tests:
#
# source [file join [file dirname [info script]] internals.tcl]
#
# Copyright © 2020 Sergey G. Brester (sebres).
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals {
namespace path ::tcltest
|
| ︙ | ︙ |
Changes to tests/interp.test.
1 2 3 4 5 6 | # This file tests the multiple interpreter facility of Tcl # # 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 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 |
# This file tests the multiple interpreter facility of Tcl
#
# 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 © 1995-1996 Sun Microsystems, Inc.
# 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.
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 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: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:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}
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 {
interp
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.3 {options for interp command} {
interp delete
} ""
test interp-1.4 {options for interp command} -returnCodes error -body {
interp delete foo bar
} -result {could not find interpreter "foo"}
test interp-1.5 {options for interp command} -returnCodes error -body {
interp exists foo bar
} -result {wrong # args: should be "interp exists ?path?"}
#
# test interp-0.6 was removed
#
test interp-1.6 {options for interp command} -returnCodes error -body {
interp children foo bar zop
} -result {wrong # args: should be "interp children ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
interp hello
} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
interp -froboz
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
interp -froboz -safe
} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.10 {options for interp command} -returnCodes error -body {
interp target
} -result {wrong # args: should be "interp target path alias"}
# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
interp create a
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 |
test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
| | | | | | | | | | | | | | | | | | | | | | | 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 |
test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr {$anothernum > $thenum}
} 1
test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr {$anothernum - $thenum}
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
foreach i [interp children] {
interp delete $i
}
# Part 2: Testing "interp children" and "interp exists"
test interp-3.1 {testing interp exists and interp children} {
interp children
} ""
test interp-3.2 {testing interp exists and interp children} {
interp create a
interp exists a
} 1
test interp-3.3 {testing interp exists and interp children} {
interp exists nonexistent
} 0
test interp-3.4 {testing interp exists and interp children} -body {
interp children a b c
} -returnCodes error -result {wrong # args: should be "interp children ?path?"}
test interp-3.5 {testing interp exists and interp children} -body {
interp exists a b c
} -returnCodes error -result {wrong # args: should be "interp exists ?path?"}
test interp-3.6 {testing interp exists and interp children} {
interp exists
} 1
test interp-3.7 {testing interp exists and interp children} -setup {
catch {interp create a}
} -body {
interp children
} -result a
test interp-3.8 {testing interp exists and interp children} -body {
interp children a b c
} -returnCodes error -result {wrong # args: should be "interp children ?path?"}
test interp-3.9 {testing interp exists and interp children} -setup {
catch {interp create a}
} -body {
interp create {a a2} -safe
expr {"a2" in [interp children a]}
} -result 1
test interp-3.10 {testing interp exists and interp children} -setup {
catch {interp create a}
catch {interp create {a a2}}
} -body {
interp exists {a a2}
} -result 1
# Part 3: Testing "interp delete"
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
| | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test interp-4.4 {testing interp delete} {
interp delete
} ""
test interp-4.5 {testing interp delete} {
interp create a
interp create {a x1}
interp delete {a x1}
expr {"x1" in [interp children a]}
} 0
test interp-4.6 {testing interp delete} {
interp create c1
interp create c2
interp create c3
interp delete c1 c2 c3
} ""
test interp-4.7 {testing interp delete} -returnCodes error -body {
interp create c1
interp create c2
interp delete c1 c2 c3
} -result {could not find interpreter "c3"}
test interp-4.8 {testing interp delete} -returnCodes error -body {
interp delete {}
} -result {cannot delete the current interpreter}
foreach i [interp children] {
interp delete $i
}
# Part 4: Consistency checking - all nondeleted interpreters should be
# there:
test interp-5.1 {testing consistency} {
interp children
} ""
test interp-5.2 {testing consistency} {
interp exists a
} 0
test interp-5.3 {testing consistency} {
interp exists nonexistent
} 0
# Recreate interpreter "a"
interp create a
# Part 5: Testing eval in interpreter object command and with interp command
test interp-6.1 {testing eval} {
a eval expr {{3 + 5}}
} 8
test interp-6.2 {testing eval} -returnCodes error -body {
a eval foo
} -result {invalid command name "foo"}
test interp-6.3 {testing eval} {
a eval {proc foo {} {expr {3 + 5}}}
a eval foo
} 8
catch {a eval {proc foo {} {expr {3 + 5}}}}
test interp-6.4 {testing eval} {
interp eval a foo
} 8
test interp-6.5 {testing eval} {
interp create {a x2}
interp eval {a x2} {proc frob {} {expr {4 * 9}}}
interp eval {a x2} frob
} 36
catch {interp create {a x2}}
test interp-6.6 {testing eval} -returnCodes error -body {
interp eval {a x2} foo
} -result {invalid command name "foo"}
# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER:
proc in_parent {args} {
return [list seen in parent: $args]
}
# Part 6: Testing basic alias creation
test interp-7.1 {testing basic alias creation} {
a alias foo in_parent
} foo
catch {a alias foo in_parent}
test interp-7.2 {testing basic alias creation} {
a alias bar in_parent a1 a2 a3
} bar
catch {a alias bar in_parent a1 a2 a3}
# Test 6.3 has been deleted.
test interp-7.3 {testing basic alias creation} {
a alias foo
} in_parent
test interp-7.4 {testing basic alias creation} {
a alias bar
} {in_parent a1 a2 a3}
test interp-7.5 {testing basic alias creation} {
lsort [a aliases]
} {bar foo}
test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body {
a aliases too many args
} -result {wrong # args: should be "a aliases"}
# Part 7: testing basic alias invocation
test interp-8.1 {testing basic alias invocation} {
catch {interp create a}
a alias foo in_parent
a eval foo s1 s2 s3
} {seen in parent: {s1 s2 s3}}
test interp-8.2 {testing basic alias invocation} {
catch {interp create a}
a alias bar in_parent a1 a2 a3
a eval bar s1 s2 s3
} {seen in parent: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} -returnCodes error -body {
catch {interp create a}
a alias
} -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"}
# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-parent
list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-parent"}}
test interp-9.2 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-parent
proc nonexistent-command-in-parent {} {return i_exist!}
a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
catch {interp create a}
a eval {proc p {} {return ENTER_A}}
interp alias {} p a p
set res {}
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
| | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-parent] != ""} {
rename nonexistent-command-in-parent {}
}
# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
} a_alias
test interp-10.6 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_command b b_command a1 a2 a3
| | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
} a_alias
test interp-10.6 {testing aliasing between interpreters} {
catch {interp delete a}
catch {interp delete b}
interp create a
interp create b
interp alias a a_command b b_command a1 a2 a3
b alias b_command in_parent b1 b2 b3
a eval a_command m1 m2 m3
} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}}
test interp-10.7 {testing aliases between interpreters} {
catch {interp delete a}
interp create a
interp alias "" foo a zoppo
a eval {proc zoppo {x} {list $x $x $x}}
set x [foo 33]
a eval {rename zoppo {}}
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
| | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
test interp-14.3 {testing interp aliases} {
catch {interp delete a}
interp create a
interp create {a x3}
interp alias {a x3} froboz "" puts
interp aliases {a x3}
} froboz
test interp-14.4 {testing interp alias - alias over parent} {
# SF Bug 641195
catch {interp delete a}
interp create a
list [catch {interp alias "" a a eval} msg] $msg [info commands a]
} {1 {cannot define or rename alias "a": interpreter deleted} {}}
test interp-14.5 {testing interp-alias: wrong # args} -body {
proc setx x {set x}
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
} ""
test interp-16.5 {testing deletion order, bgerror} {
catch {interp delete xxx}
interp create xxx
xxx eval {proc bgerror {args} {exit}}
xxx alias exit kill xxx
proc kill {i} {interp delete $i}
| | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
} ""
test interp-16.5 {testing deletion order, bgerror} {
catch {interp delete xxx}
interp create xxx
xxx eval {proc bgerror {args} {exit}}
xxx alias exit kill xxx
proc kill {i} {interp delete $i}
xxx eval after 100 expr {a + b}
after 200
update
interp exists xxx
} 0
#
# Alias loop prevention testing.
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 |
interp create x
interp alias x a x b
x eval rename a c
list [catch {x eval rename c b} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
#
| | | | | | | | | 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 |
interp create x
interp alias x a x b
x eval rename a c
list [catch {x eval rename c b} msg] $msg
} {1 {cannot define or rename alias "b": would create a loop}}
#
# Test robustness of Tcl_DeleteInterp when applied to a child interpreter.
# If there are bugs in the implementation these tests are likely to expose
# the bugs as a core dump.
#
test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete {
list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
testinterpdelete a
} ""
test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete {a b}
} ""
test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
testinterpdelete a
} ""
test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel {a b}}} msg] $msg
} {0 {}}
test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete {
catch {interp delete a}
interp create a
interp create {a b}
interp alias {a b} dodel {} dodel
proc dodel {x} {testinterpdelete $x}
list [catch {interp eval {a b} {dodel a}} msg] $msg
} {0 {}}
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
set l
} {foo {}}
test interp-19.9 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
| | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
set l
} {foo {}}
test interp-19.9 {alias deletion, renaming} {
catch {interp delete a}
interp create a
interp alias a foo a bar
interp eval a rename foo blotz
interp eval a {proc foo {} {expr {34 * 34}}}
interp alias a foo {}
set l [interp eval a foo]
interp delete a
set l
} 1156
test interp-20.1 {interp hide, interp expose and interp invokehidden} {
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
set script [makeFile {
set x [namespace current]
} script]
| | | | | | | | | | | | | | | 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 |
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.49 {interp invokehidden -namespace} -setup {
set script [makeFile {
set x [namespace current]
} script]
interp create -safe child
} -body {
child invokehidden -namespace ::foo source $script
child eval {set ::foo::x}
} -cleanup {
interp delete child
removeFile script
} -result ::foo
test interp-20.50 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
child invokehidden coroutine
} -cleanup {
interp delete child
} -returnCodes error -match glob -result *
test interp-20.50.1 {Bug 2486550} -setup {
interp create child
} -body {
child hide coroutine
catch {child invokehidden coroutine} m o
dict get $o -errorinfo
} -cleanup {
unset -nocomplain m 0
interp delete child
} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
"child invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
} ""
test interp-21.2 {interp hidden} {
interp hidden
} ""
|
| ︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 |
#
# 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
| | | | 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 |
#
# 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
# child nominally thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
# use a for so if a return -code break 'escapes' we would notice
for {set code -1} {$code<=5} {incr code} {
lappend res [catch {interp eval a return -code $code} msg]
}
|
| ︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 |
lappend res [catch {interp eval a retcode $code} msg] $msg
}
interp delete a
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
test interp-26.3 {result code transmission : aliases} {
# Test that all the possibles error codes from Tcl get passed up from the
| | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
lappend res [catch {interp eval a retcode $code} msg] $msg
}
interp delete a
set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
test interp-26.3 {result code transmission : aliases} {
# Test that all the possibles error codes from Tcl get passed up from the
# child interp's context to the parent, even though the child nominally
# thinks the command is running at the root level.
catch {interp delete a}
interp create a
set res {}
proc MyTestAlias {code} {
return -code $code ret$code
}
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup {
set interp [interp create -safe]
} -constraints knownBug -body {
# this test fails because the errorInfo is fully transmitted whether the
# interp is safe or not. The errorInfo should never report data from the
| | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 |
invoked from within
"test"}
test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup {
set interp [interp create -safe]
} -constraints knownBug -body {
# this test fails because the errorInfo is fully transmitted whether the
# interp is safe or not. The errorInfo should never report data from the
# parent interpreter because it could contain sensitive information.
proc MyError {secret} {
return -code error "msg"
}
proc MyTestAlias {interp args} {
MyError "some secret"
}
interp alias $interp test {} MyTestAlias $interp
|
| ︙ | ︙ | |||
2271 2272 2273 2274 2275 2276 2277 |
lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
} -cleanup {
interp delete $i
} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
test interp-27.6 {interp hidden & aliases & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
| | | | | | | | | | | | | | | | | | | | | | 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 |
lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
} -cleanup {
interp delete $i
} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
test interp-27.6 {interp hidden & aliases & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
set v root-parent
namespace eval foo {
variable v foo-parent
proc bar {interp args} {
variable v
list "parent bar called ($v) ([namespace current]) ($args)"\
[interp invokehidden $interp foo::bar $args]
}
}
interp eval $i {
namespace eval foo {
namespace export *
variable v foo-child
proc bar {args} {
variable v
return "child bar called ($v) ([namespace current]) ($args)"
}
}
}
set res [list [interp eval $i {namespace eval foo {bar test1}}]]
$i hide foo::bar
$i alias foo::bar foo::bar $i
set res [concat $res [interp eval $i {
set v root-child
namespace eval test {
variable v foo-test
namespace import ::foo::*
bar test2
}
}]]
} -cleanup {
namespace delete foo
interp delete $i
} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}}
test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup {
set i [interp create]
} -constraints knownBug -body {
set v root-parent
namespace eval mfoo {
variable v foo-parent
proc bar {interp args} {
variable v
list "parent bar called ($v) ([namespace current]) ($args)"\
[interp invokehidden $interp test::bar $args]
}
}
interp eval $i {
namespace eval foo {
namespace export *
variable v foo-child
proc bar {args} {
variable v
return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
}
}
set v root-child
namespace eval test {
variable v foo-test
namespace import ::foo::*
}
}
set res [list [interp eval $i {namespace eval test {bar test1}}]]
$i hide test::bar
$i alias test::bar mfoo::bar $i
set res [concat $res [interp eval $i {test::bar test2}]]
} -cleanup {
namespace delete mfoo
interp delete $i
} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}}
test interp-27.8 {hiding, namespaces and integrity} knownBug {
namespace eval foo {
variable v 3
proc bar {} {variable v; set v}
# next command would currently generate an unknown command "bar" error.
interp hide {} bar
}
namespace delete foo
list [catch {interp invokehidden {} foo::bar} msg] $msg
} {1 {invalid hidden command name "foo"}}
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
}]
} -cleanup {
rename parent {}
interp delete $i
} -result {}
test interp-28.2 {parent's nsName cache should not cross} -setup {
set i [interp create]
$i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
} -body {
$i eval {
set x {namespace children ::}
set y [list namespace children ::]
namespace delete {*}[filter [{*}$y]]
|
| ︙ | ︙ | |||
2428 2429 2430 2431 2432 2433 2434 |
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
| | | | | | | 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 |
} {1 {recursion limit must be > 0}}
test interp-29.1.7 {interp recursionlimit argument checking} {
interp create moo
set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.1.8 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo bar} msg]
interp delete moo
list $result $msg
} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}}
test interp-29.1.9 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit foo} msg]
interp delete moo
list $result $msg
} {1 {expected integer but got "foo"}}
test interp-29.1.10 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit 0} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.11 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit -1} msg]
interp delete moo
list $result $msg
} {1 {recursion limit must be > 0}}
test interp-29.1.12 {child recursionlimit argument checking} {
interp create moo
set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
interp delete moo
list $result [string range $msg 0 35]
} {1 {integer value too large to represent}}
test interp-29.2.1 {query recursion limit} {
interp recursionlimit {}
|
| ︙ | ︙ | |||
2545 2546 2547 2548 2549 2550 2551 |
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 49}
test interp-29.3.4 {recursion limit error reporting} {
| | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
set i 0
list [catch p msg] $msg $i
}]
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
}
}
}
}
} msg
}]
set r2 [child eval { set msg }]
interp delete child
list $r1 $r2
} {0 ok}
test interp-29.4.1 {recursion limit inheritance} {
set i [interp create]
set ii [interp eval $i {
interp recursionlimit {} 50
interp create
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 |
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set i 0
catch p
set i
}]
interp delete $i
set r
} 50
test interp-29.5.1 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.2 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
interp recursionlimit $i 20000
set after [interp recursionlimit {}]
set childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.3 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set childlimit [interp recursionlimit $i]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.5.4 {does child recursion limit affect parent?} {
set before [interp recursionlimit {}]
set i [interp create]
$i recursionlimit 20000
set after [interp recursionlimit {}]
set childlimit [$i recursionlimit]
interp delete $i
list [expr {$before == $after}] $childlimit
} {1 20000}
test interp-29.6.1 {safe interpreter recursion limit} {
interp create child -safe
set n [interp recursionlimit child]
interp delete child
set n
} 1000
test interp-29.6.2 {safe interpreter recursion limit} {
interp create child -safe
set n [child recursionlimit]
interp delete child
set n
} 1000
test interp-29.6.3 {safe interpreter recursion limit} {
interp create child -safe
set n1 [interp recursionlimit child 42]
set n2 [interp recursionlimit child]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.4 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [interp recursionlimit child]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.5 {safe interpreter recursion limit} {
interp create child -safe
set n1 [interp recursionlimit child 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.6 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.7 {safe interpreter recursion limit} {
interp create child -safe
set n1 [child recursionlimit 42]
set n2 [child recursionlimit]
interp delete child
list $n1 $n2
} {42 42}
test interp-29.6.8 {safe interpreter recursion limit} {
interp create child -safe
set n [catch {child eval {interp recursionlimit {} 42}} msg]
interp delete child
list $n $msg
} {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):
# # still crashes...
# proc p {} {
|
| ︙ | ︙ | |||
3167 3168 3169 3170 3171 3172 3173 |
set while while
$while {1} {
# No bytecode at all here...
}
}
}
# We use a time limit here; command limits don't trap this case
| | | 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 |
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 -seconds [expr {[clock seconds] + 2}]
$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
|
| ︙ | ︙ | |||
3189 3190 3191 3192 3193 3194 3195 |
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
| | | | 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 |
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command "cb2 [expr {$curlim + 100}]" \
-value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
|
| ︙ | ︙ | |||
3218 3219 3220 3221 3222 3223 3224 |
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
| | | 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 |
global c i
set c b
$i limit command -value $newlimit
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command "cb2 {}" -value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
|
| ︙ | ︙ | |||
3243 3244 3245 3246 3247 3248 3249 |
global c i
set c b
$i limit command -value {} -command {}
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
| | | | 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 |
global c i
set c b
$i limit command -value {} -command {}
}
} -body {
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command cb2 -value [expr {$curlim + 10}]
$i eval {for {set i 0} {$i<10} {incr i} {foo}}
list $a $b $c
} -result {6 4 b} -cleanup {
interp delete $i
rename cb1 {}
rename cb2 {}
}
test interp-34.7 {limits with callbacks: deleting the handler interp} -setup {
set i [interp create]
$i eval {
set i [interp create]
proc cb1 {} {
global c
incr ::$c
}
proc cb2 {args} {
global c i curlim
set c b
$i limit command -value [expr {$curlim + 1000}]
trapToParent
}
}
proc cb3 {} {
global i subi
interp alias [list $i $subi] foo {} cb4
interp delete $i
|
| ︙ | ︙ | |||
3285 3286 3287 3288 3289 3290 3291 |
set n 0
$i eval {
set a 0
set b 0
set c a
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
| | | | 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 |
set n 0
$i eval {
set a 0
set b 0
set c a
interp alias $i foo {} cb1
set curlim [$i eval info cmdcount]
$i limit command -command cb2 -value [expr {$curlim + 10}]
}
$i eval {
$i eval {
for {set i 0} {$i<10} {incr i} {foo}
}
}
list $n [interp exists $i]
} -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 -seconds [expr {[clock seconds] + 1}] -granularity 1
$i eval {
set x {}
vwait x
}
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
|
| ︙ | ︙ | |||
3348 3349 3350 3351 3352 3353 3354 |
proc cb2 {} {
global result
lappend result cb2
}
} -body {
set i [interp create]
set t0 [clock seconds]
| | | | 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 |
proc cb2 {} {
global result
lappend result cb2
}
} -body {
set i [interp create]
set t0 [clock seconds]
$i limit time -seconds [expr {$t0 + 1}] -granularity 1 \
-command "cb1 $i [expr {$t0 + 2}]"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<30} {incr i} {
after 100
}
}
|
| ︙ | ︙ | |||
3376 3377 3378 3379 3380 3381 3382 |
lappend result cb1
set times [lassign $times t]
$i limit time -seconds $t
}
} -body {
set i [interp create]
set t0 [clock seconds]
| | | | 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 |
lappend result cb1
set times [lassign $times t]
$i limit time -seconds $t
}
} -body {
set i [interp create]
set t0 [clock seconds]
set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]"
$i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i"
set ::result {}
lappend ::result [catch {
$i eval {
for {set i 0} {$i<30} {incr i} {
after 100
}
}
|
| ︙ | ︙ | |||
3555 3556 3557 3558 3559 3560 3561 |
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.2 {interp bgerror syntax} -body {
interp bgerror x y z
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.3 {interp bgerror syntax} -setup {
| | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test interp-36.1 {interp bgerror syntax} -body {
interp bgerror
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.2 {interp bgerror syntax} -body {
interp bgerror x y z
} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
test interp-36.3 {interp bgerror syntax} -setup {
interp create child
} -body {
child bgerror x y
} -cleanup {
interp delete child
} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"}
test interp-36.4 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror \{
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.5 {ChildBgerror syntax} -setup {
interp create child
} -body {
child bgerror {}
} -cleanup {
interp delete child
} -returnCodes error -result {cmdPrefix must be list of length >= 1}
test interp-36.6 {ChildBgerror returns handler} -setup {
interp create child
} -body {
child bgerror {foo bar soom}
} -cleanup {
interp delete child
} -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
test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
catch {interp delete a}
interp create a
set result {}
} -body {
interp create {a b} -safe
lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}]
lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}]
} -cleanup {
unset -nocomplain result
interp delete a
} -result {26 26}
test interp-38.1 {interp debug one-way switch} -setup {
catch {interp delete a}
|
| ︙ | ︙ | |||
3663 3664 3665 3666 3667 3668 3669 |
interp debug {} -frame 0 bogus
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
# cleanup
unset -nocomplain hidden_cmds
| | | 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 |
interp debug {} -frame 0 bogus
} -returnCodes {
error
} -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:
|
Changes to tests/io.test.
1 2 3 4 5 6 7 8 | # -*- tcl -*- # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # 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 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
variable umaskValue
variable path
variable f
variable i
variable n
variable v
variable msg
variable expected
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::tcltestlib [info loaded {} Tcltest]
}
package require tcltests
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testobj [llength [info commands testobj]]
testConstraint testservicemode [llength [info commands testservicemode]]
# Some things fail under Windows in Continuous Integration systems for subtle
# reasons such as CI often running with elevated privileges in a container.
testConstraint notWinCI [expr {
$::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
| | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A
fconfigure stdout -encoding binary -translation lf -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
set x [read $f]
catch {puts -nonewline $x}
if {[eof $f]} {
close $f
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
| | | | | | 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 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} stdio {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
fconfigure $f -blocking 0
set x [gets $f line]
close $f
set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdef\x1Aghijk\nwombat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1A
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdefghijk\nwom\u001abat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1A
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {11 abcdefghijk 3 wom}
# Comprehensive tests
test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
| | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
fconfigure $f -buffersize 16
set x [gets $f]
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
| | | | | | | | | 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 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg\x1A"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} {
# not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcd\refg\x1A"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding utf-16
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\n\x1A"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
# (eol == dstEnd)
|
| ︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 |
set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
set f [open $path(test1) w]
fconfigure $f -translation lf
| | | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\x1Ak9012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1A
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
# didn't produce any bytes
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
| | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
variable x {}
after 500 [namespace code { lappend x timeout }]
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
fconfigure $f -encoding shiftjis
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 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
| | | 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 |
fconfigure $f -encoding shiftjis
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 15 "1234567890123\uff10\uff11" 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 -encoding 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} {
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
| | | | 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 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
set x [list [gets $f line] $line [testchannel queuedcr $f]]
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
| | | | | | 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 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} {
# Make sure bytes are removed from buffer.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmno\r"
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
puts -nonewline $f "\x1A"
lappend x [gets $f line] $line
close $f
set x
} {15 abcdefghijklmno 1 -1 {}}
test io-9.1 {CommonGetsCleanup} emptyTest {
} {}
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
| | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
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 -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
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 "\u672c" 0]
| | | 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 |
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 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding 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+]
|
| ︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
| | | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
fileevent $f read [namespace code "ready $f"]
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
| | | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
| | | 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec {
set f [open $path(test1) w]
puts -nonewline $f {
close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
|
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 |
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
| | | 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 |
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test io-14.8 {reuse of stdio special channels} stdio {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts -nonewline $f {
close stderr
set f [}
puts $f [list open $path(test1) w]]
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 |
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
| | | 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 |
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio fileevent} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 |
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {win} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
| | | | 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 |
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {win} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} [list [list \x1A ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio {
set f [open $path(script) w]
puts -nonewline $f {
close stdout
set f1 [}
puts $f [list open $path(stdout) w]]
puts $f {
fconfigure $f1 -buffersize 777
|
| ︙ | ︙ | |||
2148 2149 2150 2151 2152 2153 2154 |
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
| | | 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 |
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
test io-26.1 {Tcl_GetChannelInstanceData} stdio {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
| | | 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 |
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose notWinCI} {
# 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 {
|
| ︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 |
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
| | | 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 |
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
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 {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 |
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
| | | 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 |
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [list {*}$consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
|
| ︙ | ︙ | |||
2490 2491 2492 2493 2494 2495 2496 |
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
| | | 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 |
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} stdio {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 "set f1 \[[list open $path(longfile) r]]"
puts $f1 {
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 |
set y broken
}
}
close $f1
close $f2
set y
} ok
| | | 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 |
set y broken
}
}
close $f1
close $f2
set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
|
| ︙ | ︙ | |||
2566 2567 2568 2569 2570 2571 2572 |
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
| | | 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 |
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio {
set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 |
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
| | | | 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 |
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
|
| ︙ | ︙ | |||
2677 2678 2679 2680 2681 2682 2683 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
| | | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
|
| ︙ | ︙ | |||
2712 2713 2714 2715 2716 2717 2718 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
| | | | | 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 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} {
file delete $path(test3)
set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
set f [open $path(test3) r]
set x [read $f]
close $f
set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} stdio {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {exit}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
|
| ︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
| | | 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
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.
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}
|
| ︙ | ︙ | |||
2823 2824 2825 2826 2827 2828 2829 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
| | | | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
set result
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose notWinCI} {
# 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}
|
| ︙ | ︙ | |||
3191 3192 3193 3194 3195 3196 3197 |
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
| | | | | | | | 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 |
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\nand\rhere\n\x1A
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1A -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
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 -eofchar \x1A -translation auto
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]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
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 -eofchar \x1A -translation auto
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]
|
| ︙ | ︙ | |||
3280 3281 3282 3283 3284 3285 3286 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
| | | | | | | | | | | 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 |
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 -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
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 -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
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.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
|
| ︙ | ︙ | |||
3728 3729 3730 3731 3732 3733 3734 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
| | | | | | | 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 |
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1A -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
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 -eofchar \x1A
fconfigure $f -translation auto
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.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
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 -eofchar \x1A -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
|
| ︙ | ︙ | |||
3817 3818 3819 3820 3821 3822 3823 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
| | | 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 |
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 -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
|
| ︙ | ︙ | |||
3839 3840 3841 3842 3843 3844 3845 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
| | | 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 |
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 -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
|
| ︙ | ︙ | |||
3861 3862 3863 3864 3865 3866 3867 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
| | | | | | | | | 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 |
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.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
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 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.26 {Tcl_Write lf, ^Z in middle, 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 -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.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
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 -eofchar {}
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 -eofchar {}
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 -eofchar {}
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]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
|
| ︙ | ︙ | |||
4089 4090 4091 4092 4093 4094 4095 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
| | | | | | 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 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.10 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.1 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.11.2 {Tcl_Read from a pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {chan configure stdout -translation crlf}
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
| ︙ | ︙ | |||
4251 4252 4253 4254 4255 4256 4257 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
| | | 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
|
| ︙ | ︙ | |||
4559 4560 4561 4562 4563 4564 4565 |
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
| | | 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 |
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} stdio {
set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
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} {
|
| ︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 |
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
| | | | 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 |
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
gets $f1
close $f1
set c
|
| ︙ | ︙ | |||
4772 4773 4774 4775 4776 4777 4778 |
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
| | | | 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 |
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
|
| ︙ | ︙ | |||
4824 4825 4826 4827 4828 4829 4830 |
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
| | | | | | | | | | | | | | | | | | | | | 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 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 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 |
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {
exit
}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1A
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {11 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 -eofchar {}
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 -eofchar {}
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 -eofchar {}
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 -eofchar {}
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 -eofchar {}
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 -eofchar {}
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]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
|
| ︙ | ︙ | |||
5029 5030 5031 5032 5033 5034 5035 |
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {8 8 1 13}
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
| | | | | | 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 |
set e [eof $f]
close $f
list $s $l $e [scan [string index $in end] %c]
} -result {8 8 1 13}
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f abc\ndef
close $f
set s [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 $s $l $e [scan [string index $in end] %c]
} -result {9 8 1 13}
test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1A
puts $f {}
close $f
set s [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 $s $l $e [scan [string index $in end] %c]
} -result {2 1 1 13}
test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
|
| ︙ | ︙ | |||
5077 5078 5079 5080 5081 5082 5083 |
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
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]
| | | | | | 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 |
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
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 -eofchar {}
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]]]
set e [eof $f]
close $f
list $c $l $e [scan [string index $in end] %c]
} {9 1 1 13}
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
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 -encoding binary -translation lf -eofchar {}
puts $f1 {
chan configure stdout -encoding binary -translation lf -eofchar {}
puts hello_from_pipe
}
flush $f1
|
| ︙ | ︙ | |||
5143 5144 5145 5146 5147 5148 5149 |
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
| | | 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 |
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
puts $f1 {exit}
|
| ︙ | ︙ | |||
5407 5408 5409 5410 5411 5412 5413 |
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
| | | 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 |
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
|
| ︙ | ︙ | |||
5498 5499 5500 5501 5502 5503 5504 |
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
| | | 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 |
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
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 binary
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
|
| ︙ | ︙ | |||
5647 5648 5649 5650 5651 5652 5653 |
} {0o600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat $path(test3) stats
| | | | 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 |
} {0o600 {line 1}}
test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
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]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
|
| ︙ | ︙ | |||
5847 5848 5849 5850 5851 5852 5853 |
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
| | | | | 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 |
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
set result {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r "read f"
fileevent $f2 r "read f2"
fileevent $f3 r "read f3"
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f2 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f3 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {text}
test io-44.2 {FileEventProc procedure: error in read event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
|
| ︙ | ︙ | |||
5904 5905 5906 5907 5908 5909 5910 |
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
| | | | > > < > > | | 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 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 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 |
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent} -body {
fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
}]
variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} -constraints {
stdio unixExecs fileevent
} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
list $x [fileevent $f2 writable]
} -cleanup {
interp bgerror {} $handler
catch {close $f2}
catch {close $f3}
} -result {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} -constraints {
stdio unixExecs fileevent
} -body {
set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {
namespace eval refchan {
|
| ︙ | ︙ | |||
6080 6081 6082 6083 6084 6085 6086 |
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
| | > < | > | 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 |
lappend x [catch {fileevent $f readable}] \
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} {
testfevent create
set script "set f \[[list open $path(foo) r]]\n"
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
set timer [after 10 lappend x timeout]
testfevent cmd $script
vwait x
after cancel $timer
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
variable x 0
|
| ︙ | ︙ | |||
6281 6282 6283 6284 6285 6286 6287 |
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
| | | 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 |
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
|
| ︙ | ︙ | |||
6351 6352 6353 6354 6355 6356 6357 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6379 6380 6381 6382 6383 6384 6385 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6407 6408 6409 6410 6411 6412 6413 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6435 6436 6437 6438 6439 6440 6441 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6463 6464 6465 6466 6467 6468 6469 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6491 6492 6493 6494 6495 6496 6497 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6519 6520 6521 6522 6523 6524 6525 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation lf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6547 6548 6549 6550 6551 6552 6553 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6575 6576 6577 6578 6579 6580 6581 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation cr
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6603 6604 6605 6606 6607 6608 6609 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6631 6632 6633 6634 6635 6636 6637 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -eofchar \x1A -translation crlf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
file delete $path(test1)
|
| ︙ | ︙ | |||
6659 6660 6661 6662 6663 6664 6665 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
| | | 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 |
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1A
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
|
| ︙ | ︙ | |||
6779 6780 6781 6782 6783 6784 6785 |
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
| | > | < > | > > | > > > > | | > < < < | > > > > > > > > > | < | < | > < < < | | > > > > > > > > > | < | < < | > > | < > > > > > > > > | < | < | > < < < < > > | > | > > > > > > > > > | < | | < | > < < < > > | > | > | 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 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 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 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 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 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 |
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
update
proc delhandler {f} {
variable z
set z called
testchannelevent $f delete 0
}
set z not_called
set timer [after 50 lappend z timeout]
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f]]
testservicemode 1
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result called
test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc delhandler {f i} {
variable z
lappend z "called delhandler $i"
testchannelevent $f delete 0
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{called delhandler 0} {called delhandler 1}}
test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
set z ""
proc notcalled {f i} {
variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
variable z
testchannelevent $f delete 1
lappend z "delhandler $i called"
testchannelevent $f delete 0
lappend z "delhandler $i deleted myself"
}
set z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delhandler 0 called} {delhandler 0 deleted myself}}
test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
update
} -body {
set f [open $path(test1) w]
close $f
update
proc delrecursive {f} {
variable z
variable u
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
} else {
lappend z "delrecursive calling recursive"
set u recursive
update
}
}
variable u toplevel
variable z ""
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delrecursive $f]]
testservicemode 1
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc notcalled {f} {
variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
variable u
variable z
if {"$u" == "recursive"} {
testchannelevent $f delete 1
lappend z "del deleted notcalled"
testchannelevent $f delete 0
lappend z "del deleted myself"
} else {
set u recursive
lappend z "del calling recursive"
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "del after recursive"
}
}
set z ""
set u toplevel
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
testservicemode 1
set timer [after 50 set z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result [list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after recursive}]
test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
close $f
proc first {f} {
variable u
variable z
variable done
if {"$u" == "toplevel"} {
lappend z "first called"
set u first
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
lappend z "first after toplevel"
set done 1
} else {
lappend z "first called not toplevel"
}
}
proc second {f} {
variable u
variable z
|
| ︙ | ︙ | |||
6934 6935 6936 6937 6938 6939 6940 6941 6942 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
update
close $f
| > > > > > > > > > > > > > < | | | < < | 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 |
} else {
lappend z "second called, cannot happen!"
testchannelevent $f removeall
}
}
set z ""
set u toplevel
set done 0
testservicemode 0
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
testservicemode 1
update
if {!$done} {
set timer2 [after 200 set done 1]
vwait done
after cancel $timer2
}
set z
} -cleanup {
close $f
} -result [list {first called} {first called not toplevel} \
{second called, first time} {second called, second time} \
{first after toplevel}]
test io-51.1 {Test old socket deletion on Macintosh} {socket} {
set x 0
set result ""
proc accept {s a p} {
variable x
variable wait
fconfigure $s -blocking off
|
| ︙ | ︙ | |||
7131 7132 7133 7134 7135 7136 7137 |
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
| | | 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 |
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
|
| ︙ | ︙ | |||
7411 7412 7413 7414 7415 7416 7417 |
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
| | | 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 |
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
|
| ︙ | ︙ | |||
7443 7444 7445 7446 7447 7448 7449 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
| | | 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(pipe)
set f1 [open $path(pipe) w]
|
| ︙ | ︙ | |||
7527 7528 7529 7530 7531 7532 7533 |
set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
| | | | | | 7577 7578 7579 7580 7581 7582 7583 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 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 |
set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
set in [open "|[list [interpreter] $path(pipe)]" r+]
set out [open $path(test1) w]
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
set fcopyTestDone ;# 0 for plain end of file
} {0}
proc doFcopy {in out {bytes 0} {error {}}} {
variable fcopyTestDone
variable fcopyTestCount
incr fcopyTestCount $bytes
if {[string length $error]} {
set fcopyTestDone 1
} elseif {[eof $in]} {
set fcopyTestDone 0
} else {
# Delay next fcopy to wait for size>0 input bytes
after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
set fcopyTestCount 0
set f1 [open $path(pipe) w]
puts $f1 {
# Write 10 bytes / 10 msec
|
| ︙ | ︙ | |||
7593 7594 7595 7596 7597 7598 7599 |
exit 0
}
close $f1
set in [open "|[list [interpreter] $path(pipe) &]" r+]
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
| | | 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 |
exit 0
}
close $f1
set in [open "|[list [interpreter] $path(pipe) &]" r+]
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
# -1=error 0=script error N=number of bytes
expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
} {3450}
|
| ︙ | ︙ | |||
7619 7620 7621 7622 7623 7624 7625 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Record input size, so that result is always defined
lappend ::RES [file size $bar]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
set sbs [file size $bar]
lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs
|
| ︙ | ︙ | |||
7660 7661 7662 7663 7664 7665 7666 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
# Initialize and force eof on the input.
seek $f 0 end ; read $f 1
set ::RES [eof $f]
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 2 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
|
| ︙ | ︙ | |||
7700 7701 7702 7703 7704 7705 7706 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
| | | 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 |
}
# Files we use for our channels
set foo [makeFile ashgdfashdgfasdhgfasdhgf foo]
set bar [makeFile {} bar]
# Channels to copy between
set f [open $foo r] ; fconfigure $f -translation binary
set g [open $bar w] ; fconfigure $g -translation binary -buffering none
} -constraints {stdio fcopy} -body {
set ::RES {}
# Run the copy. Should not invoke -command now.
fcopy $f $g -size 0 -command ::cmd
# Check that -command was not called synchronously
lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}]
# Now let the async part happen. Should capture the eof in cmd
# If not break the event loop via timer.
|
| ︙ | ︙ | |||
7757 7758 7759 7760 7761 7762 7763 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
| | | 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 |
}
proc ::done args {
set ::forever OK
return
}
set ::forever {}
set out [open $out w]
} -constraints {stdio fcopy} -body {
fcopy $pipe $out -size 6 -command ::done
set token [after 5000 {
set ::forever {fcopy hangs}
}]
vwait ::forever
catch {after cancel $token}
set ::forever
|
| ︙ | ︙ | |||
7827 7828 7829 7830 7831 7832 7833 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
| | | 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 |
}
set a [socket 127.0.0.1 9999]
set b [socket 127.0.0.1 9999]
fconfigure $a -translation binary -buffering none
fconfigure $b -translation binary -buffering none
fileevent $a readable [list ::done $a]
fileevent $b readable [list ::done $b]
} -constraints {stdio fcopy} -body {
# Now pass data through the server in both directions.
set ::forever {}
puts $a AB
vwait ::forever
puts $b BA
vwait ::forever
set ::forever
|
| ︙ | ︙ | |||
7875 7876 7877 7878 7879 7880 7881 |
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
| | | 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 |
set done
} -cleanup {
close $outChan
close $inChan
removeFile out
removeFile in
} -result {40 bytes copied}
test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
fconfigure stdin -translation binary -blocking 0
fconfigure stdout -buffering none -translation binary
fcopy stdin stdout
}
|
| ︙ | ︙ | |||
8081 8082 8083 8084 8085 8086 8087 |
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
| | | 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 |
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
test io-54.1 {Recursive channel events} {socket fileevent notWinCI} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
|
| ︙ | ︙ | |||
8290 8291 8292 8293 8294 8295 8296 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
| | | 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ | |||
8330 8331 8332 8333 8334 8335 8336 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
| | | 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out "catch {load $::tcltestlib Tcltest}"
puts $out {
puts [testbytestring \xe2]
exit 1
|
| ︙ | ︙ | |||
8708 8709 8710 8711 8712 8713 8714 |
removeFile io-73.5
} -result [list 1 1 more\u00a0data 1]
test io-74.1 {[104f2885bb] improper cache validity check} -setup {
set fn [makeFile {} io-74.1]
set rfd [open $fn r]
testobj freeallvars
| | | | | 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 |
removeFile io-73.5
} -result [list 1 1 more\u00a0data 1]
test io-74.1 {[104f2885bb] improper cache validity check} -setup {
set fn [makeFile {} io-74.1]
set rfd [open $fn r]
testobj freeallvars
interp create child
} -constraints testobj -body {
teststringobj set 1 [string range $rfd 0 end]
read [teststringobj get 1]
testobj duplicate 1 2
interp transfer {} $rfd child
catch {read [teststringobj get 1]}
read [teststringobj get 2]
} -cleanup {
interp delete child
testobj freeallvars
removeFile io-74.1
} -returnCodes error -match glob -result {can not find channel named "*"}
# ### ### ### ######### ######### #########
# cleanup
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
1 2 3 4 5 6 7 8 | # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # # 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 |
# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
# fblocked, fconfigure, open, channel, fcopy
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# 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.
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]]
package require tcltests
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
#----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 |
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
| | | 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 |
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
# Magic to get the test* commands in the children
load {} Tcltest $ida
load {} Tcltest $idb
# Set up channel in interpreter
interp eval $ida $helperscript
set chan [interp eval $ida {
proc foo {args} {oninit seek; onfinal; track; return}
|
| ︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 |
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
| | | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 |
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
set ida [interp create];#puts <<$ida>>
set idb [interp create];#puts <<$idb>>
# Magic to get the test* commands in the children
load {} Tcltest $ida
load {} Tcltest $idb
# Set up channel in thread
set chan [interp eval $ida $helperscript]
set chan [interp eval $ida {
proc foo {args} {
|
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 |
interp delete $idb
} -constraints {testchannel} -result {Owner lost}
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
| | | | | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
interp delete $idb
} -constraints {testchannel} -result {Owner lost}
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
} {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.
# -*- tcl -*-
|
| ︙ | ︙ |
Changes to tests/ioTrans.test.
1 2 3 4 5 6 7 | # -*- tcl -*- # Functionality covered: operation of the reflected transformation # # 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 41 42 43 44 45 46 47 |
# -*- tcl -*-
# Functionality covered: operation of the reflected transformation
#
# 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 © 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# 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]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# testchannel cut|splice Both needed to test the reflection in threads.
# thread::send
#----------------------------------------------------------------------
# ### ### ### ######### ######### #########
## Testing the reflected transformation.
# Helper commands to record the arguments to handler methods. Stored in a
# script so that the tests needing this code do not need their own copy but
# can access this variable.
set helperscript {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# This forces the return options to be in the order that the test expects!
variable optorder {
-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
-errorstack !?!
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 |
# --- === *** ###########################
# '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 iortrans-11.0 {origin interpreter of moved transform gone} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
| | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
# --- === *** ###########################
# '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 iortrans-11.0 {origin interpreter of moved transform gone} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
# Magic to get the test* commands in the children
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
# Set up channel and transform in interpreter
interp eval $ida $helperscript
interp eval $ida [list ::variable tempchan [tempchan]]
interp transfer {} $::tempchan $ida
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 |
} -cleanup {
tempdone
interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
} -cleanup {
tempdone
interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
set ida [interp create]; #puts <<$ida>>
set idb [interp create]; #puts <<$idb>>
# Magic to get the test* commands in the children
load {} Tcltest $ida
load {} Tcltest $idb
} -constraints {testchannel} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
interp eval $ida [list ::variable tempchan [tempchan]]
interp transfer {} $::tempchan $ida
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 |
set res
}]
} -cleanup {
interp delete $idb
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
| | | | | | | | | | 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 |
set res
}]
} -cleanup {
interp delete $idb
tempdone
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create child
# Magic to get the test* commands into the child
load {} Tcltest child
} -constraints {testchannel} -body {
# Get base channel into the child
set c [tempchan]
testchannel cut $c
interp eval child [list testchannel splice $c]
interp eval child [list set c $c]
child eval {
proc no-op args {}
proc driver {c sub args} {
return {initialize finalize read write}
}
set t [chan push $c [list driver $c]]
chan event $c readable no-op
}
interp delete child
} -cleanup {
tempdone
} -result {}
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
|
| ︙ | ︙ |
Changes to tests/iogt.test.
1 2 3 4 5 6 7 8 | # -*- tcl -*- # Commands covered: transform, and stacking in general # # This file contains a collection of tests for Giot # # 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 |
# -*- tcl -*-
# Commands covered: transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright © 2000 Ajuba Solutions.
# Copyright © 2000 Andreas Kupries.
# All rights reserved.
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]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
|
| ︙ | ︙ |
Changes to tests/join.test.
1 2 3 4 5 6 | # Commands covered: join # # 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 |
# Commands covered: join
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test join-1.1 {basic join commands} {
join {a b c} xyz
} axyzbxyzc
test join-1.2 {basic join commands} {
|
| ︙ | ︙ |
Changes to tests/lindex.test.
1 2 3 4 5 6 | # Commands covered: lindex # # 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 |
# Commands covered: lindex
#
# 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 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001 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.
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]]
set minus -
testConstraint testevalex [llength [info commands testevalex]]
# Tests of Tcl_LindexObjCmd, NOT COMPILED
test lindex-1.1 {wrong # args} testevalex {
|
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
test lindex-2.4 {malformed index list} testevalex {
set x \{
list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
# Indices that are integers or convertible to integers
| | | | | | | | | | | | | | | | | | 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 |
test lindex-2.4 {malformed index list} testevalex {
set x \{
list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
# Indices that are integers or convertible to integers
test lindex-3.1 {integer -1} -constraints testevalex -body {
set x ${minus}1
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {{} {}}
test lindex-3.2 {integer 0} -constraints testevalex -body {
set x [string range 00 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {a a}
test lindex-3.3 {integer 2} -constraints testevalex -body {
set x [string range 22 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {c c}
test lindex-3.4 {integer 3} -constraints testevalex -body {
set x [string range 33 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {{} {}}
test lindex-3.5 {bad octal} -constraints testevalex -body {
set x 0o8
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-3.6 {bad octal} -constraints testevalex -body {
set x -0o9
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-3.7 {indexes don't shimmer wide ints} -body {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
} -result {2147483646 {} 2147483647 2147483648}
test lindex-3.8 {compiled with static indices out of range, negative} -body {
list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
} -result [lrepeat 3 {}]
test lindex-3.9 {compiled with calculated indices out of range, negative constant} -body {
list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
} -result [lrepeat 3 {}]
test lindex-3.10 {compiled with calculated indices out of range, after end} -body {
list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
} -result [lrepeat 3 {}]
# Indices relative to end
test lindex-4.1 {index = end} testevalex {
set x end
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
test lindex-7.3 {quoted elements} testevalex {
testevalex {lindex {ab "c d \" x" y} 1}
} {c d " x}
test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
| | | | | | > > | | | | | | | | > > | | 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 |
test lindex-7.3 {quoted elements} testevalex {
testevalex {lindex {ab "c d \" x" y} 1}
} {c d " x}
test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
test lindex-8.1 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x $x}
} -result 0
test lindex-8.2 {data reuse} -constraints testevalex -body {
set a 0
testevalex {lindex $a $a $a}
} -result 0
test lindex-8.3 {data reuse} -constraints {
testevalex
} -body {
set a 1
testevalex {lindex $a $a $a}
} -result {}
test lindex-8.4 {data reuse} -constraints testevalex -body {
set x [list 0 0]
testevalex {lindex $x $x}
} -result 0
test lindex-8.5 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x [list $x $x]}
} -result 0
test lindex-8.6 {data reuse} -constraints testevalex -body {
set x [list 1 1]
testevalex {lindex $x $x}
} -result {}
test lindex-8.7 {data reuse} -constraints {
testevalex
} -body {
set x 1
testevalex {lindex $x [list $x $x]}
} -result {}
#----------------------------------------------------------------------
# Compilation tests for lindex
test lindex-9.1 {wrong # args} {
list [catch {lindex} result] $result
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
} {{}}
test lindex-15.3 {quoted elements} {
catch {
lindex {ab "c d \" x" y} 1
} result
set result
} {c d " x}
| | | | | | | | | | | | | | | | | | < | < < | < < < | < | > | < > | | > > > | 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 |
} {{}}
test lindex-15.3 {quoted elements} {
catch {
lindex {ab "c d \" x" y} 1
} result
set result
} {c d " x}
test lindex-15.4 {quoted elements} -body {
catch {
lindex {a b {c d "e} {f g"}} 2
} result
set result
} -result {c d "e}
test lindex-16.1 {data reuse} -body {
set x 0
catch {
lindex $x $x
} result
set result
} -result {0}
test lindex-16.2 {data reuse} -body {
set a 0
catch {
lindex $a $a $a
} result
set result
} -result 0
test lindex-16.3 {data reuse} -body {
set a 1
catch {
lindex $a $a $a
} result
set result
} -result {}
test lindex-16.4 {data reuse} -body {
set x [list 0 0]
catch {
lindex $x $x
} result
set result
} -result {0}
test lindex-16.5 {data reuse} -body {
set x 0
catch {
lindex $x [list $x $x]
} result
set result
} -result {0}
test lindex-16.6 {data reuse} -body {
set x [list 1 1]
catch {
lindex $x $x
} result
set result
} -result {}
test lindex-16.7 {data reuse} -body {
set x 1
catch {
lindex $x [list $x $x]
} result
set result
} -result {}
test lindex-17.0 {Bug 1718580} -body {
lindex {} end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
test lindex-17.1 {Bug 1718580} -body {
lindex a end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
test lindex-18.0 {nested bytecode execution} -setup {
proc demo {i} {lindex {a b c} $i}
} -body {
demo 0+0x10000000000000000
} -cleanup {
rename demo {}
}
catch { unset minus }
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/link.test.
1 2 3 4 5 6 | # Commands covered: none # # This file contains a collection of tests for Tcl_LinkVar and related library # procedures. 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_LinkVar and related library
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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.
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 testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
unset -nocomplain $i
}
|
| ︙ | ︙ |
Changes to tests/linsert.test.
1 2 3 4 5 6 | # Commands covered: linsert # # 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 |
# Commands covered: linsert
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset lis}
catch {rename p ""}
test linsert-1.1 {linsert command} {
|
| ︙ | ︙ |
Changes to tests/list.test.
1 2 3 4 5 6 | # Commands covered: list # # 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 |
# Commands covered: list
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# First, a bunch of individual tests
test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
|
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
concat {}
# Check that tclListObj.c's SetListFromAny handles possible overlarge
# string rep lengths in the source object.
proc slowsort list {
set result {}
| | | | | | | | | 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 |
concat {}
# Check that tclListObj.c's SetListFromAny handles possible overlarge
# string rep lengths in the source object.
proc slowsort list {
set result {}
set last [expr {[llength $list] - 1}]
while {$last > 0} {
set minIndex [expr {[llength $list] - 1}]
set min [lindex $list $last]
set i [expr {$minIndex - 1}]
while {$i >= 0} {
if {[string compare [lindex $list $i] $min] < 0} {
set minIndex $i
set min [lindex $list $i]
}
incr i -1
}
set result [concat $result [list $min]]
if {$minIndex == 0} {
set list [lrange $list 1 end]
} else {
set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \
[lrange $list [expr {$minIndex + 1}] end]]
}
set last [expr {$last - 1}]
}
return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
|
| ︙ | ︙ |
Changes to tests/listObj.test.
1 2 3 4 5 6 7 | # Functionality covered: operation of the procedures in tclListObj.c that # implement the Tcl type manager for the list object type. # # 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 |
# Functionality covered: operation of the procedures in tclListObj.c that
# implement the Tcl type manager for the list object type.
#
# 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 © 1995-1996 Sun Microsystems, Inc.
# 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.
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 testobj [llength [info commands testobj]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
# Test removed; tested an internal detail
# that's no longer correct, and duplicated test obj-1.1
|
| ︙ | ︙ |
Changes to tests/llength.test.
1 2 3 4 5 6 | # Commands covered: llength # # 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 |
# Commands covered: llength
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test llength-1.1 {length of list} {
llength {a b c d}
} 4
test llength-1.2 {length of list} {
|
| ︙ | ︙ |
Changes to tests/lmap.test.
1 2 3 4 5 6 | # Commands covered: lmap, continue, break # # 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 |
# Commands covered: lmap, continue, break
#
# 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-1997 Sun Microsystems, Inc.
# Copyright © 2011 Trevor Davel
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain a b i x
# ----- Non-compiled operation -----------------------------------------------
|
| ︙ | ︙ |
Changes to tests/load.test.
1 2 3 4 5 6 | # Commands covered: load # # 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 |
# Commands covered: load
#
# 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 © 1995 Sun Microsystems, Inc.
# 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.
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]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | testConstraint teststaticpkg [llength [info commands teststaticpkg]] # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
testConstraint teststaticpkg [llength [info commands teststaticpkg]]
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
test load-1.1 {basic errors} -returnCodes error -body {
load
} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
test load-1.2 {basic errors} -returnCodes error -body {
load a b c d
} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
test load-1.3 {basic errors} -returnCodes error -body {
load a b foobar
} -result {could not find interpreter "foobar"}
test load-1.4 {basic errors} -returnCodes error -body {
load -global {}
} -result {must specify either file name or package name}
test load-1.5 {basic errors} -returnCodes error -body {
load -lazy {} {}
} -result {must specify either file name or package name}
test load-1.6 {basic errors} -returnCodes error -body {
load {} Unknown
} -result {package "Unknown" isn't 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 {couldn't figure out package name for -global}
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
load -global [file join $testDir pkga$ext]
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load -lazy [file join $testDir pkgb$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 load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"if 44 {open non_existent}"
invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
| | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
"open non_existent"
invoked from within
"if 44 {open non_existent}"
invoked from within
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
test load-3.2 {error in _Init procedure, child interpreter} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
set ::errorCode foo
set ::errorInfo bar
set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
$msg $::errorInfo $::errorCode]
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
invoked from within
"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
} {0 {}}
test load-4.2 {reloading package into same interpreter} -setup {
| | | | < > | | | > < | | | | | | | | | > | < < < > > | | < < | | | | < | | | < | | | > > | < | > > > | < | | | > > > | 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 |
invoked from within
"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
} {0 {}}
test load-4.2 {reloading package into same interpreter} -setup {
catch {load [file join $testDir pkga$ext] Pkga}
} -constraints [list $dll $loaded] -returnCodes error -body {
load [file join $testDir pkga$ext] Pkgb
} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""
test load-5.1 {file name not specified and no static package: pick default} -setup {
catch {interp delete x}
interp create x
} -constraints [list $dll $loaded] -body {
load -global [file join $testDir pkga$ext] Pkga
load {} Pkga x
info loaded x
} -cleanup {
interp delete x
} -result [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
# they cause the process to exit.
#
# As of 2005, such ancient broken systems no longer matter.
test load-6.1 {errors loading file} [list $dll $loaded] {
catch {load foo foo}
} {1}
test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg Test 1 0
load {} test
load {} test child
list [set x] [child eval set x]
} {loaded loaded}
test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg 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 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
set x "not loaded"
teststaticpkg More 0 1
load {} more
set x
} {not loaded}
catch {load [file join $testDir pkga$ext] Pkga}
catch {load [file join $testDir pkgb$ext] Pkgb}
catch {load [file join $testDir pkge$ext] Pkge}
set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]]
test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup {
teststaticpkg Test 1 0
teststaticpkg Another 0 0
teststaticpkg More 0 1
} -constraints [list teststaticpkg $dll $loaded] -body {
teststaticpkg Double 0 1
teststaticpkg Double 0 1
info loaded
} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]
testConstraint teststaticpkg_8.x 0
if {[testConstraint teststaticpkg]} {
catch {
teststaticpkg Test 1 1
teststaticpkg Another 0 1
teststaticpkg More 0 1
teststaticpkg Double 0 1
testConstraint teststaticpkg_8.x 1
}
}
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded]
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]]
test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body {
info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded {}]
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]]
test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded child]
} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
load [file join $testDir pkgb$ext] Pkgb
list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]]
} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
} -constraints {teststaticpkg} -body {
child1 eval { teststaticpkg Loadninepointone 0 1 }
child2 eval { teststaticpkg Loadninepointone 0 1 }
list [child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} -match glob -cleanup {
interp delete child1
interp delete child2
} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}}
test load-10.1 {load from vfs} -setup {
set dir [pwd]
cd $testDir
testsimplefilesystem 1
} -constraints [list $dll $loaded testsimplefilesystem] -body {
list [catch {load simplefs:/pkgd$ext PKGD} msg] $msg
} -result {0 {}} -cleanup {
testsimplefilesystem 0
cd $dir
unset dir
}
test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \
[list $dll $loaded] {
load [file join $testDir pkgooa$ext]
list [pkgooa_stubsok] [lsort [info commands pkgooa_*]]
} {1 pkgooa_stubsok}
|
| ︙ | ︙ |
Changes to tests/lpop.test.
1 2 3 4 5 6 | # Commands covered: lpop # # 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 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
# Commands covered: lpop
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain no; # following tests expecting var "no" does not exists
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
} -result {can't read "no": no such variable}
test lpop-1.2 {error conditions} -returnCodes error -body {
lpop no 0
} -result {can't read "no": no such variable}
test lpop-1.3 {error conditions} -returnCodes error -body {
set l "x {}x"
lpop l
} -result {list element in braces followed by "x" instead of space}
test lpop-1.4 {error conditions} -returnCodes error -body {
set l "x y"
lpop l -1
} -result {index "-1" out of range}
test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body {
set l "x y"
list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l
} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}}
test lpop-1.5 {error conditions} -returnCodes error -body {
set l "x y z"
lpop l 3
} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX}
test lpop-1.6 {error conditions} -returnCodes error -body {
set l "x y"
lpop l end+1
} -result {index "end+1" out of range}
test lpop-1.7 {error conditions} -returnCodes error -body {
set l "x y"
lpop l {}
} -match glob -result {bad index *}
test lpop-1.8 {error conditions} -returnCodes error -body {
set l "x y"
lpop l 0 0 0 0 1
} -result {index "1" out of range}
test lpop-1.9 {error conditions} -returnCodes error -body {
set l "x y"
lpop l {1 0}
} -match glob -result {bad index *}
test lpop-2.1 {basic functionality} -body {
set l "x y z"
list [lpop l 0] $l
} -result {x {y z}}
test lpop-2.2 {basic functionality} -body {
|
| ︙ | ︙ |
Changes to tests/lrange.test.
1 2 3 4 5 6 | # Commands covered: lrange # # 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 |
# Commands covered: lrange
#
# 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 Sun Microsystems, Inc.
# 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.
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 testpurebytesobj [llength [info commands testpurebytesobj]]
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
} {}
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
| | | | | | | | 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 |
} {}
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
test lrange-3.4 {compiled with calculated indices out of range, after end} -body {
list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
} -result [lrepeat 4 {}]
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
} [lrepeat 4 {a b}]
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
} [lrepeat 4 {b c}]
test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
[lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
[$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
# (as before the fix [58c46e74b931d3a1]):
test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
# 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"
| | | | | | | | 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 |
# 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
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/lrepeat.test.
1 2 3 4 5 6 | # Commands covered: lrepeat # # 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 |
# Commands covered: lrepeat
#
# 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 © 2003 Simon Geard.
#
# 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::*
}
## Arg errors
test lrepeat-1.1 {error cases} {
-body {
lrepeat
|
| ︙ | ︙ |
Changes to tests/lreplace.test.
1 2 3 4 5 6 | # Commands covered: lreplace # # 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 |
# Commands covered: lreplace
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
test lreplace-1.29 {lreplace command} -body {
lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
| | | | | | | | | | | | | | | | 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 |
test lreplace-1.29 {lreplace command} -body {
lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-2.1 {lreplace errors} -body {
list [catch lreplace msg] $msg
} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.2 {lreplace errors} -body {
list [catch {lreplace a b} msg] $msg
} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.3 {lreplace errors} -body {
list [catch {lreplace x a 10} msg] $msg
} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.4 {lreplace errors} -body {
list [catch {lreplace x 10 x} msg] $msg
} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} -body {
list [catch {lreplace x 10 1x} msg] $msg
} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} -body {
list [catch {lreplace x 3 2} msg] $msg
} -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
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
foreach a $idxs {
foreach b $idxs {
foreach i $ins {
set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
set tester [list lreplace $ls $a $b {*}$i]
set script [list catch $tester m]
set script "list \[$script\] \$m"
| | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
foreach a $idxs {
foreach b $idxs {
foreach i $ins {
set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
set tester [list lreplace $ls $a $b {*}$i]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lreplace-6.[incr n] {lreplace battery} -body \
[list apply [list {} $script]] -result $expected
}
}
}
}
}}
# cleanup
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
1 2 3 4 5 6 | # Commands covered: lsearch # # 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 |
# Commands covered: lsearch
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
lsearch $x 123
} 2
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
test lsearch-5.3 {binary search finds leftmost occurrences} {
set res {}
for {set i 0} {$i < 10} {incr i} {
lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} {
set res {}
for {set i 9} {$i >= 0} {incr i -1} {
lappend res [lsearch -sorted -integer -decreasing \
$repeatingDecreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {3 5}
test lsearch-14.8 {combinations: -start, -inline and -not} {
lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4}
test lsearch-15.1 {make sure no shimmering occurs} {
| | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 |
lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {3 5}
test lsearch-14.8 {combinations: -start, -inline and -not} {
lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4}
test lsearch-15.1 {make sure no shimmering occurs} {
set x [expr {int(sin(0))}]
lsearch -start $x $x $x
} 0
test lsearch-16.1 {lsearch -regexp shared object} {
set str a
lsearch -regexp $str $str
} 0
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
lsearch -index {} [list \{] \{
} 0
test lsearch-17.11 {lsearch -index option, empty argument} {
lsearch -index {} [list \{] \{
} [lsearch [list \{] \{]
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
lsearch -index -2 a a
| | | | | | | 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 |
lsearch -index {} [list \{] \{
} 0
test lsearch-17.11 {lsearch -index option, empty argument} {
lsearch -index {} [list \{] \{
} [lsearch [list \{] \{]
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
lsearch -index -2 a a
} -returnCodes error -result {index "-2" out of range}
test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
lsearch -index -1-1 a a
} -returnCodes error -result {index "-1-1" out of range}
test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
lsearch -index end--1 a a
} -returnCodes error -result {index "end--1" out of range}
test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+1 a a
} -returnCodes error -result {index "end+1" out of range}
test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+2 a a
} -returnCodes error -result {index "end+2" out of range}
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} 1
test lsearch-18.2 {lsearch -index option, list as index basic functionality} {
lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
| ︙ | ︙ |
Changes to tests/lset.test.
1 2 3 4 5 6 7 8 | # This file is a -*- tcl -*- test script # Commands covered: lset # # 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 |
# This file is a -*- tcl -*- test script
# Commands covered: lset
#
# 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 © 2001 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.
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]]
proc failTrace {name1 name2 op} {
error "trace failed"
}
testConstraint testevalex [llength [info commands testevalex]]
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list -1] w}
} msg] $msg
| | | | | | | | | | | | 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 |
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list -1] w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list 4] w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end--2] w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end+2] w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end-3] w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex {
set a "x \{"
list [catch {
testevalex {lset a 0 y}
} msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
set a {x y z}
list [catch {
testevalex {lset a 2a2 w}
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a -1 w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a 4 w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end--2 w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end+2 w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end-3 w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex {
list [catch {
testevalex {lset noWrite 0 d}
} msg] $msg $noWrite
} {1 {can't set "noWrite": trace failed} {d b c}}
test lset-5.2 {lset, not compiled, 3 args, can't set variable} testevalex {
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
test lset-8.4 {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
| | | | | | | | | | | | 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 |
test lset-8.4 {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.6 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 -1} h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.7 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 3 h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.8 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 3} h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.9a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end--2 h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.9b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end+2 h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.10a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end--2} h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.10b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end+2} h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.11 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end-2 h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-8.12 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end-2} h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-9.1 {lset, not compiled, entire variable} testevalex {
set a x
list [testevalex {lset a y}] $a
} {y y}
test lset-9.2 {lset, not compiled, entire variable} testevalex {
set a x
|
| ︙ | ︙ |
Changes to tests/lsetComp.test.
1 2 3 4 5 6 7 8 | # This file is a -*- tcl -*- test script # Commands covered: lset # # 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 |
# This file is a -*- tcl -*- test script
# Commands covered: lset
#
# 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 © 2001 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
} "0 {{1 2} {3 5}}"
test lsetComp-2.8 {lset, compiled, list of args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
| | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
} "0 {{1 2} {3 5}}"
test lsetComp-2.8 {lset, compiled, list of args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
} {1 {index "5" out of range}}
test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x { 1 5 } 5
}
list $::x [lindex $::x 1]
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
} "0 {{1 2} {3 5}}"
test lsetComp-3.8 {lset, compiled, flat args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x 1 5 5
}
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
} "0 {{1 2} {3 5}}"
test lsetComp-3.8 {lset, compiled, flat args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x 1 5 5
}
} {1 {index "5" out of range}}
test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x 1 5 5
}
list $::x [lindex $::x 1]
|
| ︙ | ︙ |
Changes to tests/macOSXFCmd.test.
1 2 3 4 5 6 | # This file tests the tclMacOSXFCmd.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 |
# This file tests the tclMacOSXFCmd.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.
#
# Copyright © 2003 Tcl Core Team.
#
# 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::*
}
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ |
Changes to tests/macOSXLoad.test.
1 2 3 4 5 6 | # Commands covered: load unload # # 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 |
# Commands covered: load unload
#
# 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 © 1995 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set oldTSF $::tcltest::testSingleFile
set ::tcltest::testSingleFile false
if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" &&
![string match *pkga* [info loaded]]} {
|
| ︙ | ︙ |
Changes to tests/main.test.
1 2 | # This file contains a collection of tests for generic/tclMain.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 |
# This file contains a collection of tests for generic/tclMain.c.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::main {
namespace import ::tcltest::*
# Is [exec] defined?
testConstraint exec [llength [info commands exec]]
# Is the tcl::test package loaded?
testConstraint tcl::test [expr {
[llength [package provide tcl::test]]
&& [package vsatisfies [package provide tcl::test] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
foreach line [split $script \n] {
if {[catch {
puts $chan $line
flush $chan
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
} -result {0 {-enc utf-8 script}}
# Tests Tcl_Main-2.*: application-initialization procedure
test Tcl_Main-2.1 {
Tcl_Main: appInitProc returns error
} -constraints {
| | | | | | | 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 |
} -result {0 {-enc utf-8 script}}
# Tests Tcl_Main-2.*: application-initialization procedure
test Tcl_Main-2.1 {
Tcl_Main: appInitProc returns error
} -constraints {
exec tcl::test
} -setup {
makeFile {puts "In script"} script
} -body {
exec [interpreter] script -appinitprocerror >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
removeFile script
} -result "application-specific initialization failed: \nIn script\n"
test Tcl_Main-2.2 {
Tcl_Main: appInitProc returns error
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} -appinitprocerror >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "application-specific initialization failed: \nIn script\n"
test Tcl_Main-2.3 {
Tcl_Main: appInitProc deletes interp
} -constraints {
exec tcl::test
} -setup {
makeFile {puts "In script"} script
} -body {
exec [interpreter] script -appinitprocdeleteinterp >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
removeFile script
} -result "application-specific initialization failed: \n"
test Tcl_Main-2.4 {
Tcl_Main: appInitProc deletes interp
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocdeleteinterp >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "application-specific initialization failed: \n"
test Tcl_Main-2.5 {
Tcl_Main: appInitProc closes stderr
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocclosestderr >& result
set f [open result]
read $f
} -cleanup {
close $f
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
removeFile script
} -match glob -result [join [list 1 {child process exited abnormally}\
"missing close-brace\n while executing*"] \n]
test Tcl_Main-3.5 {
Tcl_Main: startup script sets main loop
} -constraints {
| | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
removeFile script
} -match glob -result [join [list 1 {child process exited abnormally}\
"missing close-brace\n while executing*"] \n]
test Tcl_Main-3.5 {
Tcl_Main: startup script sets main loop
} -constraints {
exec tcl::test
} -setup {
makeFile {
rename exit _exit
proc exit {code} {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
file delete result
removeFile script
} -result "event\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-3.6 {
Tcl_Main: startup script sets main loop and closes stdin
} -constraints {
| | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
file delete result
removeFile script
} -result "event\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-3.6 {
Tcl_Main: startup script sets main loop and closes stdin
} -constraints {
exec tcl::test
} -setup {
makeFile {
close stdin
testsetmainloop
rename exit _exit
proc exit {code} {
puts "In exit"
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
file delete result
removeFile script
} -result "event\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-3.7 {
Tcl_Main: startup script deletes interp
} -constraints {
| | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
file delete result
removeFile script
} -result "event\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-3.7 {
Tcl_Main: startup script deletes interp
} -constraints {
exec tcl::test
} -setup {
makeFile {
rename exit _exit
proc exit {code} {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
file delete result
removeFile script
} -result "even 0\n"
test Tcl_Main-3.8 {
Tcl_Main: startup script deletes interp and sets mainloop
} -constraints {
| | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
file delete result
removeFile script
} -result "even 0\n"
test Tcl_Main-3.8 {
Tcl_Main: startup script deletes interp and sets mainloop
} -constraints {
exec tcl::test
} -setup {
makeFile {
testsetmainloop
rename exit _exit
proc exit {code} {
puts "In exit"
_exit $code
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
} -result {}
# Tests Tcl_Main-4.*: rc file evaluation
test Tcl_Main-4.1 {
Tcl_Main: rcFile evaluation deletes interp
} -constraints {
| | | | | 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 |
} -result {}
# Tests Tcl_Main-4.*: rc file evaluation
test Tcl_Main-4.1 {
Tcl_Main: rcFile evaluation deletes interp
} -constraints {
exec tcl::test
} -setup {
set rc [makeFile {testinterpdelete {}} rc]
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocsetrcfile $rc >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
removeFile rc
} -result "application-specific initialization failed: \n"
test Tcl_Main-4.2 {
Tcl_Main: rcFile evaluation closes stdin
} -constraints {
exec tcl::test
} -setup {
set rc [makeFile {close stdin} rc]
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocsetrcfile $rc >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
removeFile rc
} -result "application-specific initialization failed: \n"
test Tcl_Main-4.3 {
Tcl_Main: rcFile evaluation closes stdin and sets main loop
} -constraints {
exec tcl::test
} -setup {
set rc [makeFile {
close stdin
testsetmainloop
after 0 testexitmainloop
testexithandler create 0
rename exit _exit
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.4 {
Tcl_Main: rcFile evaluation sets main loop
} -constraints {
| | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.4 {
Tcl_Main: rcFile evaluation sets main loop
} -constraints {
exec tcl::test
} -setup {
set rc [makeFile {
testsetmainloop
after 0 testexitmainloop
testexithandler create 0
rename exit _exit
proc exit code {
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.5 {
Tcl_Main: Bug 1481986
} -constraints {
| | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
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+]
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ | |||
694 695 696 697 698 699 700 |
file delete result
} -result "bar\n"
test Tcl_Main-5.8 {
Tcl_Main: interactive mode: close stdin
-> main loop & [exit] & exit handlers
} -constraints {
| | | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
file delete result
} -result "bar\n"
test Tcl_Main-5.8 {
Tcl_Main: interactive mode: close stdin
-> main loop & [exit] & exit handlers
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-5.9 {
Tcl_Main: interactive mode: delete interp
-> main loop & exit handlers, but no [exit]
} -constraints {
| | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-5.9 {
Tcl_Main: interactive mode: delete interp
-> main loop & exit handlers, but no [exit]
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
close $f
file delete result
} -result "Exit MainLoop\neven 0\n"
test Tcl_Main-5.10 {
Tcl_Main: exit main loop in mid-interactive command
} -constraints {
| | | | 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 |
close $f
file delete result
} -result "Exit MainLoop\neven 0\n"
test Tcl_Main-5.10 {
Tcl_Main: exit main loop in mid-interactive command
} -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 {
close $f
} -result [list 0 {Exit MainLoop} 0 {1 2} 0 {3 4}]
test Tcl_Main-5.11 {
Tcl_Main: EOF in interactive main loop
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
close $f
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-5.12 {
Tcl_Main: close stdin in interactive main loop
} -constraints {
| | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
close $f
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-5.12 {
Tcl_Main: close stdin in interactive main loop
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
close $f
file delete result
} -result "1\n% "
test Tcl_Main-6.2 {
Tcl_Main: prompt deletes interp
} -constraints {
| | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
close $f
file delete result
} -result "1\n% "
test Tcl_Main-6.2 {
Tcl_Main: prompt deletes interp
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
set tcl_prompt1 {testinterpdelete {}}
set tcl_interactive 1
puts "not reached"
} >& result
set f [open result]
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
close $f
file delete result
} -result "1\n% YES\n"
test Tcl_Main-6.5 {
Tcl_Main: interactive entry to main loop
} -constraints {
| | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 |
close $f
file delete result
} -result "1\n% YES\n"
test Tcl_Main-6.5 {
Tcl_Main: interactive entry to main loop
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
set tcl_interactive 1
testsetmainloop
testexitmainloop} >& result
set f [open result]
read $f
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
} -result "1\n% % "
# Tests Tcl_Main-7.*: exiting
test Tcl_Main-7.1 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
| | | | | | 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 |
} -result "1\n% % "
# Tests Tcl_Main-7.*: exiting
test Tcl_Main-7.1 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
proc exit args {}
testexithandler create 0
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "even 0\n"
test Tcl_Main-7.2 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
proc exit args {}
testexithandler create 0
after 0 testexitmainloop
testsetmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "Exit MainLoop\neven 0\n"
# Tests Tcl_Main-8.*: StdinProc operations
test Tcl_Main-8.1 {
StdinProc: handles non-blocking stdin
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
chan configure stdin -blocking 0
testexitmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "Exit MainLoop\n"
test Tcl_Main-8.2 {
StdinProc: handles stdin EOF
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
testexithandler create 0
rename exit _exit
proc exit code {
puts "In exit"
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
close $f
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-8.3 {
StdinProc: handles interactive stdin EOF
} -constraints {
| | | | 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 |
close $f
file delete result
} -result "Exit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-8.3 {
StdinProc: handles interactive stdin EOF
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
testexithandler create 0
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
set tcl_interactive 1} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n% even 0\n"
test Tcl_Main-8.4 {
StdinProc: handles stdin close
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
close $f
file delete result
} -result "1\nExit MainLoop\nIn exit\n"
test Tcl_Main-8.5 {
StdinProc: handles interactive stdin close
} -constraints {
| | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
close $f
file delete result
} -result "1\nExit MainLoop\nIn exit\n"
test Tcl_Main-8.5 {
StdinProc: handles interactive stdin close
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
set tcl_interactive 1
rename exit _exit
proc exit code {
puts "In exit"
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 |
close $f
file delete result
} -result "1\n% % % after#0\n% after#1\n% 1\nExit MainLoop\nIn exit\n"
test Tcl_Main-8.6 {
StdinProc: handles event loop re-entry
} -constraints {
| | | | | | | | | | 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 |
close $f
file delete result
} -result "1\n% % % after#0\n% after#1\n% 1\nExit MainLoop\nIn exit\n"
test Tcl_Main-8.6 {
StdinProc: handles event loop re-entry
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
after 100 {puts 1; set delay 1}
vwait delay
puts 2
testexitmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n2\nExit MainLoop\n"
test Tcl_Main-8.7 {
StdinProc: handling of errors
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
error foo
testexitmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "foo\nExit MainLoop\n"
test Tcl_Main-8.8 {
StdinProc: handling of errors, closed stderr
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
close stderr
error foo
testexitmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "Exit MainLoop\n"
test Tcl_Main-8.9 {
StdinProc: interactive output
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
set tcl_interactive 1
testexitmainloop} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n% % Exit MainLoop\n"
test Tcl_Main-8.10 {
StdinProc: interactive output, closed stdout
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
close stdout
set tcl_interactive 1
testexitmainloop
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result {}
test Tcl_Main-8.11 {
StdinProc: prompt deletes interp
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
set tcl_prompt1 {testinterpdelete {}}
set tcl_interactive 1} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n"
test Tcl_Main-8.12 {
StdinProc: prompt closes stdin
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
set tcl_prompt1 {close stdin}
after 100 testexitmainloop
set tcl_interactive 1
puts "not reached"
} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\nExit MainLoop\n"
test Tcl_Main-8.13 {
Bug 1775878
} -constraints {
exec tcl::test
} -body {
exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
|
| ︙ | ︙ |
Changes to tests/mathop.test.
1 2 3 4 5 6 | # Commands covered: ::tcl::mathop::... # # 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 |
# Commands covered: ::tcl::mathop::...
#
# 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 © 2006 Donal K. Fellows
# Copyright © 2006 Peter Spjuth
#
# 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::*
}
# A namespace to test that operators are exported and that they
# work when imported
namespace eval ::testmathop2 {
namespace import ::tcl::mathop::*
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 |
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]} {
| | | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
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
|
| ︙ | ︙ |
Changes to tests/misc.test.
1 2 3 4 5 6 7 | # Commands covered: various # # This file contains a collection of miscellaneous Tcl tests that # don't fit naturally in any of the other test files. Many of these # tests are pathological cases that caused bugs in earlier Tcl # releases. # | | | | | | | | 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 |
# Commands covered: various
#
# This file contains a collection of miscellaneous Tcl tests that
# don't fit naturally in any of the other test files. Many of these
# tests are pathological cases that caused bugs in earlier Tcl
# releases.
#
# Copyright © 1992-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# 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.
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 testhashsystemhash [llength [info commands testhashsystemhash]]
test misc-1.1 {error in variable ref. in command in array reference} {
proc tstProc {} {
global a
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
1 2 3 4 | # This file contains a collection of tests for the msgcat package. # 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 |
# This file contains a collection of tests for the msgcat package.
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1998 Mark Harrison.
# Copyright © 1998-1999 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2002. (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.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
if {[catch {package require msgcat 1.6}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test."
return
}
namespace eval ::msgcat::test {
|
| ︙ | ︙ |
Changes to tests/namespace-old.test.
1 2 3 4 5 6 7 8 9 | # Functionality covered: this file contains slightly modified versions of # the original tests written by Mike McLennan of Lucent Technologies for # the procedures in tclNamesp.c that implement Tcl's basic support for # namespaces. Other namespace-related tests appear in namespace.test # and variable.test. # # 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 |
# Functionality covered: this file contains slightly modified versions of
# the original tests written by Mike McLennan of Lucent Technologies for
# the procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in namespace.test
# and variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1997 Lucent Technologies
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test namespace-old-1.1 {usage for "namespace" command} {
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
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} {
| | | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
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?
|
| ︙ | ︙ |
Changes to tests/namespace.test.
1 2 3 4 5 6 7 8 | # Functionality covered: this file contains a collection of tests for the # procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic # support for namespaces. Other namespace-related tests appear in # variable.test. # # 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 |
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic
# support for namespaces. Other namespace-related tests appear in
# variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
# found in the file 'upvar.test'.
#
# Clear out any namespaces called test_ns_*
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
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 {
| | | | | | | | | 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 |
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 the global namespace
# (indirectly, via deleting ::tcl) deletes the ensemble.
child eval {rename ::tcl::info::commands ::infocommands}
child hide infocommands
child eval {
proc foo {} {
namespace delete ::
}
}
} -body {
child eval foo
child invokehidden infocommands
} -cleanup {
interp delete child
} -result {}
test namespace-7.8 {Bug ba1419303b4c} -setup {
namespace eval ns1 {
namespace ensemble create
}
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
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} {
| | | | | | | | | | | | | | | | 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 |
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
} {bar
invoked from within
"child eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create child
child eval {trace add variable errorCode write {namespace delete :: ;#}}
catch {child eval error foo bar baz}
interp delete child
set ::errorInfo
} {bar
invoked from within
"child eval error foo bar baz"}
test namespace-8.7 {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 ::errorCode
} baz
test namespace-9.1 {Tcl_Import, empty import pattern} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 |
}
}
} -result 1_2 -cleanup {
namespace delete ::test_ns_1
namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
| | | | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 |
}
}
} -result 1_2 -cleanup {
namespace delete ::test_ns_1
namespace delete ::test_ns_2
}
test namespace-51.16 {Bug 1566526} {
interp create child
child eval namespace eval demo namespace path ::
interp delete child
} {}
test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
set result {}
catch {namespace delete ::a}
} -body {
namespace eval ::a {
proc c {} {lappend ::result A}
|
| ︙ | ︙ | |||
2996 2997 2998 2999 3000 3001 3002 |
rename ::unknown unknown.save
namespace eval :: {
proc unknown args {
return SUCCESS
}
}
catch {rename ::noSuchCommand {}}
| | | | | | | 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 |
rename ::unknown unknown.save
namespace eval :: {
proc unknown args {
return SUCCESS
}
}
catch {rename ::noSuchCommand {}}
set ::child [interp create]
} -body {
$::child alias bar noSuchCommand
namespace eval test_ns_1 {
namespace unknown unknown
proc unknown args {
return FAIL
}
$::child eval bar
}
} -cleanup {
interp delete $::child
unset ::child
namespace delete test_ns_1
rename ::unknown {}
rename unknown.save ::unknown
namespace eval :: [list namespace unknown $handler]
} -result SUCCESS
test namespace-52.12 {unknown: error case must not reset handler} -body {
namespace eval foo {
|
| ︙ | ︙ | |||
3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 |
namespace ensemble create
}
} -body {
namespace-56.5 cmd
} -cleanup {
namespace delete namespace-56.5
} -result 1
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
namespace ensemble create
}
} -body {
namespace-56.5 cmd
} -cleanup {
namespace delete namespace-56.5
} -result 1
test namespace-57.0 {
an imported alias should be usable in the deletion trace for the alias
see 29e8848eb976
} -body {
variable res {}
namespace eval ns2 {
namespace export *
proc p1 {oldname newname op} {
return success
}
interp alias {} [namespace current]::p2 {} [namespace which p1]
}
namespace eval ns3 {
namespace import ::ns2::p2
}
set ondelete [list apply [list {oldname newname op} {
variable res
catch {
ns3::p2 $oldname $newname $op
} cres
lappend res $cres
} [namespace current]]]
trace add command ::ns2::p2 delete $ondelete
rename ns2::p2 {}
return $res
} -cleanup {
unset res
namespace delete ns2
namespace delete ns3
} -result success
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
|
| ︙ | ︙ |
Changes to tests/notify.test.
1 2 3 4 5 6 7 8 9 10 | # -*- tcl -*- # # notify.test -- # # This file tests several functions in the file, 'generic/tclNotify.c'. # # 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 |
# -*- tcl -*-
#
# notify.test --
#
# This file tests several functions in the file, 'generic/tclNotify.c'.
#
# 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 © 2003 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
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 testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
-body {
set delivered {}
|
| ︙ | ︙ |
Changes to tests/nre.test.
1 2 3 4 5 6 | # Commands covered: proc, apply, [interp alias], [namespce import] # # This file contains a collection of tests for the non-recursive executor that # avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the # actual command functionality is tested in the specific test file. # | | | | | | 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 |
# Commands covered: proc, apply, [interp alias], [namespce import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
# Copyright © 2008 Miguel Sofer.
#
# 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 testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ |
Changes to tests/obj.test.
1 2 3 4 5 6 7 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # 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 41 42 43 44 |
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# 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.
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 testobj [llength [info commands testobj]]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
bytearray
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}}
|
| ︙ | ︙ |
Changes to tests/oo.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # 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 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcl::oo 1.0.3
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.
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
return [expr {$end - $tmp}]
}
}
test oo-0.1 {basic test of OO's ability to clean up its initial state} {
interp create t
t eval {
| | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
return [expr {$end - $tmp}]
}
}
test oo-0.1 {basic test of OO's ability to clean up its initial state} {
interp create t
t eval {
package require tcl::oo
}
interp delete t
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
set i [interp create]
interp eval $i {
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
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
interp delete foo
}
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
interp create t
} -body {
t eval {
| | | | | | | | 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 |
interp delete foo
}
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
interp create t
} -body {
t eval {
package require tcl::oo
namespace path oo
list [catch {class destroy} m] $m [catch {object destroy} m] $m
}
} -cleanup {
interp delete t
} -result {0 {} 1 {invalid command name "object"}}
test oo-0.7 {cleaning the core class pair; way #2} -setup {
interp create t
} -body {
t eval {
package require tcl::oo
namespace path oo
list [catch {object destroy} m] $m [catch {class destroy} m] $m
}
} -cleanup {
interp delete t
} -result {0 {} 1 {invalid command name "class"}}
test oo-0.8 {leak in variable management} -setup {
oo::class create foo
} -constraints memory -body {
oo::define foo {
constructor {} {
variable v 0
}
}
leaktest {[foo new] destroy}
} -cleanup {
foo destroy
} -result 0
test oo-0.9 {various types of presence of the tcl::oo package} {
list [lsearch -nocase -all -inline [package names] tcl::oo] \
[package present tcl::oo] [expr {$::oo::patchlevel in [package versions tcl::oo]}]
} [list tcl::oo $::oo::patchlevel 1]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
lappend result [oo::object create foo]
lappend result [oo::objdefine foo {
method bar args {
global result
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
B create C
A destroy
}
} -cleanup {
rename test-oo-1.18 {}
} -result 0
test oo-1.18.3 {Bug 21c144f0f5} -setup {
| | | | | | | | | | | 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 |
B create C
A destroy
}
} -cleanup {
rename test-oo-1.18 {}
} -result 0
test oo-1.18.3 {Bug 21c144f0f5} -setup {
interp create child
} -body {
child eval {
oo::define [oo::class create foo] superclass oo::class
oo::class destroy
}
} -cleanup {
interp delete child
}
test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
interp create child
} -body {
child eval {
oo::class create A
oo::class create B {
superclass oo::class
constructor {} {
next {superclass A}
next {superclass -append A}
}
}
[B create C] create d
}
} -returnCodes error -cleanup {
interp delete child
} -result {class should only be a direct superclass once}
test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup {
interp create child
} -body {
child eval {
oo::class create A
oo::class create B {
superclass oo::class
constructor {c} {
next {superclass A}
next [list superclass -append {*}$c]
}
}
[B create C {B C}] create d
}
} -returnCodes error -cleanup {
interp delete child
} -result {attempt to form circular dependency graph}
test oo-1.19 {basic test of OO functionality: teardown order} -body {
oo::object create o
namespace delete [info object namespace o]
o destroy
# Crashes on error
} -returnCodes error -result {invalid command name "o"}
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::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::abstract ::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 {
| | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::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::abstract ::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
}
} -body {
subinterp eval {
oo::define oo::object constructor {} {
lappend ::result [info level 0]
}
lappend result 1
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}}
test oo-3.1 {basic test of OO functionality: destructor} -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 {
| | | | 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 |
} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}}
test oo-3.1 {basic test of OO functionality: destructor} -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
}
} -body {
subinterp eval {
oo::define oo::object destructor {
lappend ::result died
}
lappend result 1 [oo::object create foo]
lappend result 2 [rename foo {}]
oo::define oo::object destructor {}
return $result
}
} -cleanup {
interp delete subinterp
} -result {1 ::foo died 2 {}}
test oo-3.2 {basic test of OO functionality: destructor} -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
}
} -body {
subinterp eval {
oo::define oo::object destructor {
lappend ::result died
}
lappend result 1 [oo::object create foo]
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
superclass foo
method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
}
lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
set ::result {}
| | | | | | 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
superclass foo
method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
}
lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
test oo-7.9 {OO: defining inheritance in namespaces} -setup {
set ::result {}
oo::class create ::parent
namespace eval ::foo {
oo::class create mixin {superclass ::parent}
}
} -cleanup {
::parent destroy
namespace delete ::foo
} -body {
namespace eval ::foo {
oo::class create bar {superclass parent}
oo::class create boo
oo::define boo {superclass bar}
oo::define boo {mixin mixin}
oo::class create spong {superclass boo}
return
}
} -result {}
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
test oo-13.5 {OO: changing an object's class: non-class to class} -setup {
oo::object create fooObj
} -body {
oo::objdefine fooObj {
class oo::class
}
oo::define fooObj {
| | | | 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 |
test oo-13.5 {OO: changing an object's class: non-class to class} -setup {
oo::object create fooObj
} -body {
oo::objdefine fooObj {
class oo::class
}
oo::define fooObj {
method x {} {expr {1+2+3}}
}
[fooObj new] x
} -cleanup {
fooObj destroy
} -result 6
test oo-13.6 {OO: changing an object's class: class to non-class} -setup {
oo::class create foo
unset -nocomplain ::result
} -body {
set result dangling
oo::define foo {
method x {} {expr {1+2+3}}
}
oo::class create boo {
superclass foo
destructor {set ::result "ok"}
}
boo new
foo create bar
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
test oo-13.7 {OO: changing an object's class} -setup {
oo::class create foo
oo::class create bar
unset -nocomplain result
} -body {
oo::define bar method x {} {return ok}
oo::define foo {
| | | | 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 |
test oo-13.7 {OO: changing an object's class} -setup {
oo::class create foo
oo::class create bar
unset -nocomplain result
} -body {
oo::define bar method x {} {return ok}
oo::define foo {
method x {} {expr {1+2+3}}
self mixin foo
}
lappend result [foo x]
oo::objdefine foo class bar
lappend result [foo x]
} -cleanup {
foo destroy
bar destroy
} -result {6 ok}
test oo-13.8 {OO: changing an object's class to itself} -setup {
oo::class create foo
} -body {
oo::define foo {
method x {} {expr {1+2+3}}
}
oo::objdefine foo class foo
} -cleanup {
foo destroy
} -returnCodes error -result {may not change classes into an instance of themselves}
test oo-13.9 {OO: changing an object's class: roots are special} -setup {
set i [interp create]
|
| ︙ | ︙ | |||
2113 2114 2115 2116 2117 2118 2119 |
oo::objdefine i method bar {} {return foobar}
i bar
} -cleanup {
c destroy
mix destroy
} -result >>foobar<<
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
| | | | | | | | | | | | | | | | 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 |
oo::objdefine i method bar {} {return foobar}
i bar
} -cleanup {
c destroy
mix destroy
} -result >>foobar<<
test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create A {
superclass parent
method egg {} {
return chicken
}
}
oo::class create B {
superclass parent
mixin A
method bar {} {
# mixin from A
my egg
}
}
oo::class create C {
superclass parent
mixin B
method foo {} {
# mixin from B
my bar
}
}
[C new] foo
} -result chicken
test oo-14.7 {OO and filters from mixins of mixins} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create A {
superclass parent
method egg {} {
return chicken
}
filter f
method f args {
set m [lindex [self target] 1]
return "($m) [next {*}$args] ($m)"
}
}
oo::class create B {
superclass parent
mixin A
filter f
method bar {} {
# mixin from A
my egg
}
}
oo::class create C {
superclass parent
mixin B
filter f
method foo {} {
# mixin from B
my bar
}
}
[C new] foo
} -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)}
test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
set ::result {}
oo::class create parent {
method test {} {}
}
} -cleanup {
parent destroy
} -body {
oo::class create mix {
superclass parent
method test {} {lappend ::result mix; next; return $::result}
}
oo::class create cls {
superclass parent
mixin mix
method test {} {lappend ::result cls; next; return $::result}
}
[cls new] test
} -result {mix cls}
test oo-14.9 {OO: class mixins must be unique in list} -setup {
oo::class create parent
|
| ︙ | ︙ | |||
2918 2919 2920 2921 2922 2923 2924 |
} -result {1 foo {foo
while executing
"error foo"
(in definition script for object "::INST" line 1)
invoked from within
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
test oo-18.8 {OO: define/self command support} -setup {
| | | | | | | | | | | | | | 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 |
} -result {1 foo {foo
while executing
"error foo"
(in definition script for object "::INST" line 1)
invoked from within
"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
test oo-18.8 {OO: define/self command support} -setup {
oo::class create parent
oo::class create ::foo {superclass parent}
} -body {
catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
dict get $opt -errorinfo
} -cleanup {
parent destroy
} -result {foobar
while executing
"error foobar"
(in definition script for class object "::bar" line 1)
invoked from within
"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
while executing
"error err"
(in definition script for class "::now_this_is_a_very_very_long..." line 1)
invoked from within
"oo::define $c {error err}"}
test oo-18.10 {OO: define/self command support} -setup {
oo::class create parent
oo::class create ::foo {superclass parent}
} -body {
catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
dict get $opt -errorinfo
} -cleanup {
parent destroy
} -result {foobar
while executing
"error foobar"
(in definition script for class object "::foo" line 1)
invoked from within
"self {rename ::foo {}; error foobar}"
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {self {rename ::foo {}; error foobar}}"}
test oo-18.11 {OO: define/self command support} -setup {
oo::class create parent
oo::class create ::foo {superclass parent}
} -body {
catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
dict get $opt -errorinfo
} -cleanup {
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}}"}
|
| ︙ | ︙ | |||
3597 3598 3599 3600 3601 3602 3603 |
} -cleanup {
foo destroy
} -body {
oo::objdefine foo variable a b c
info object variables foo
} -result {a b c}
test oo-27.3 {variables declaration - basic behaviour} -setup {
| | | | | | | | 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 |
} -cleanup {
foo destroy
} -body {
oo::objdefine foo variable a b c
info object variables foo
} -result {a b c}
test oo-27.3 {variables declaration - basic behaviour} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
foo create bar
bar y
bar y
} -result 3
test oo-27.4 {variables declaration - destructors too} -setup {
oo::class create parent
set result bad!
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
destructor {set ::result ${x!}}
}
foo create bar
bar y
|
| ︙ | ︙ | |||
3643 3644 3645 3646 3647 3648 3649 |
variable x!
method y {} {incr x!}
}
foo y
foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
| | | | | | | | 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 |
variable x!
method y {} {incr x!}
}
foo y
foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
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 local]}
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
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x!
constructor {} {set x! 1}
method y {} {incr x!}
}
oo::class create foo2 {
superclass foo
variable y!
|
| ︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 |
test oo-27.8 {variables declaration - error cases - ns separators} -body {
oo::define oo::object variable bad::var
} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
test oo-27.9 {variables declaration - error cases - arrays} -body {
oo::define oo::object variable bad(var)
} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup {
| | | | | 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 |
test oo-27.8 {variables declaration - error cases - ns separators} -body {
oo::define oo::object variable bad::var
} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
test oo-27.9 {variables declaration - error cases - arrays} -body {
oo::define oo::object variable bad(var)
} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable clsvar
constructor {} {
set clsvar 0
}
method step {} {
incr clsvar
return
|
| ︙ | ︙ | |||
3723 3724 3725 3726 3727 3728 3729 |
inst2 step
inst1 step
inst2 step
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
| | | | | 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 |
inst2 step
inst1 step
inst2 step
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable clsvar
constructor {} {
set clsvar 0
}
method step {} {
incr clsvar
return
|
| ︙ | ︙ | |||
3796 3797 3798 3799 3800 3801 3802 |
}
list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
[foo exists] [catch {foo get} msg] $msg
} -cleanup {
foo destroy
} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
test oo-27.14 {variables declaration - multiple use} -setup {
| | | | | | | | | | | | | | | | | 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 |
}
list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
[foo exists] [catch {foo get} msg] $msg
} -cleanup {
foo destroy
} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
test oo-27.14 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.15 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable
variable x y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.16 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -clear
variable y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.17 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -set y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.18 {variables declaration - multiple use} -setup {
oo::class create parent
} -cleanup {
parent destroy
} -body {
oo::class create foo {
superclass parent
variable x
variable -? y
method boo {} {
return [incr x],[incr y]
}
}
foo create bar
|
| ︙ | ︙ | |||
3964 3965 3966 3967 3968 3969 3970 |
oo::objdefine foo variable v v v t t v t
info object variable foo
} -cleanup {
foo destroy
} -result {v t}
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
oo::class create Super
| | | | | | | 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 |
oo::objdefine foo variable v v v t t v t
info object variable foo
} -cleanup {
foo destroy
} -result {v t}
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
oo::class create Super
oo::class create Parent {
superclass Super
variable member1 member2
constructor {} {
set member1 parent1
set member2 parent2
}
method getChild {} {
Child new [self]
}
}
oo::class create Child {
superclass Super
variable member1 result
constructor {m} {
set [namespace current]::member1 child1
set ns [info object namespace $m]
namespace upvar $ns member1 l1 member2 l2
upvar 1 member1 l3 member2 l4
[format namespace] upvar $ns member1 l5 member2 l6
[format upvar] 1 member1 l7 member2 l8
set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8]
}
method result {} {return $result}
}
} -body {
[[Parent new] getChild] result
} -cleanup {
Super destroy
} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2}
# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
test oo-28.1 {scripted extensions to oo::define} -setup {
interp create foo
foo eval {oo::class create cls {export eval}}
} -cleanup {
|
| ︙ | ︙ | |||
4203 4204 4205 4206 4207 4208 4209 |
$s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
}] -result \
{unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
set s [SampleSlot new]
| < | 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 |
$s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
}] -result \
{unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
list \
[$s -clear
$s contents] \
[$s -append p q r
$s contents] \
[$s -appendifnew q s r t p
|
| ︙ | ︙ |
Changes to tests/ooNext2.test.
1 2 3 4 | # This file contains a collection of tests for Tcl's built-in object system. # 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 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcl::oo 1.0.3
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
# subclass was not there.
# Common setup:
# any invocation of bar should emit "abc\nhi\n" then return to its
# caller
set testopts {
-setup {
| | | | | | 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 |
# subclass was not there.
# Common setup:
# any invocation of bar should emit "abc\nhi\n" then return to its
# caller
set testopts {
-setup {
oo::class create Parent
oo::class create Foo {
superclass Parent
method bar {} {
puts abc
tailcall puts hi
puts xyz
}
}
oo::class create Foo2 {
superclass Parent
}
}
-cleanup {
Parent destroy
}
}
# these succeed, showing that without [next] the bug doesn't fire
test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
[Foo create foo] bar
} -output [join {abc hi} \n]\n
|
| ︙ | ︙ |
Changes to tests/ooUtil.test.
1 2 3 4 5 | # This file contains a collection of tests for functionality originally # sourced from the ooutil package in Tcllib. 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 |
# This file contains a collection of tests for functionality originally
# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
# the tests and generates output for errors. No output means no errors were
# found.
#
# Copyright © 2014-2016 Andreas Kupries
# Copyright © 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.
package require tcl::oo 1.0.3
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test ooUtil-1.1 {TIP 478: classmethod} -setup {
oo::class create parent
} -body {
oo::class create ActiveRecord {
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
classmethod find args {
return "[self] called with arguments: $args"
}
}
oo::class create Table {
superclass ActiveRecord
}
# This is confirming that this is not the parent interpreter
list [Table find foo bar] [info globals childinterp]
}
} -cleanup {
interp delete $childinterp
} -result {{::Table called with arguments: foo bar} {}}
test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
set safeinterp [interp create -safe]
|
| ︙ | ︙ |
Changes to tests/opt.test.
1 2 3 4 5 6 | # Package covered: opt1.0/optparse.tcl # # 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 |
# Package covered: opt1.0/optparse.tcl
#
# 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-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# the package we are going to test
package require opt 0.4.8
# we are using implementation specifics to test the package
#### functions tests #####
set n $::tcl::OptDescN
test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} {
list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr {$n+1}]] [::tcl::OptKeyRegister {}]
} "$n [expr {$n+1}] [expr {$n+2}]"
test opt-2.1 {OptKeyDelete} {
list [::tcl::OptKeyRegister {} testkey] \
[info exists ::tcl::OptDesc(testkey)] \
[::tcl::OptKeyDelete testkey] \
[info exists ::tcl::OptDesc(testkey)]
} {testkey 1 {} 0}
|
| ︙ | ︙ |
Changes to tests/package.test.
1 2 3 4 5 6 7 | # This file contains tests for the package and ::pkg::* commands. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # 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 |
# This file contains tests for the package and ::pkg::* commands.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2011 Donal K. Fellows
#
# 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]]
# Do all this in a child interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoChildInterpreter $i {*}$argv
catch [list load {} Tcltest $i]
interp eval $i {
namespace import -force ::tcltest::*
#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}
# No tests for FindPackage; can't think up anything detectable errors.
test package-5.1 {TclFreePackageInfo procedure} {
| | | | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 x.y-3.2
} -returnCodes error -result {expected version number but got "x.y"}
# No tests for FindPackage; can't think up anything detectable errors.
test package-5.1 {TclFreePackageInfo procedure} {
interp create child
child eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
package provide q 4.3
package unknown "will this get freed?"
}
interp delete child
} {}
test package-5.2 {TclFreePackageInfo procedure} -body {
interp create foo
foo eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 |
} finally {
interp delete $ip
}
}
test package-13.0 {package prefer defaults} -body {
prefer
| | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 |
} finally {
interp delete $ip
}
}
test package-13.0 {package prefer defaults} -body {
prefer
} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}]
test package-13.1 {package prefer defaults} -body {
set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant!
prefer
} -cleanup {
unset -nocomplain ::env(TCL_PKG_PREFER_LATEST)
} -result latest
|
| ︙ | ︙ |
Changes to tests/parse.test.
1 2 3 4 | # This file contains a collection of tests for the procedures in the # file tclParse.c. 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 |
# This file contains a collection of tests for the procedures in the
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 |
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
| | | | | | | | | | | 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 |
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
set ::child [interp create]
$::child alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
proc foo args {lappend ::info namespace}
$::child eval bar
testevalobjv 1 [list $::child eval bar]
uplevel #0 [list $::child eval bar]
}
namespace delete test_ns_1
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
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
unset -nocomplain x
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
test parse-10.1 {Tcl_EvalTokens, simple text} testevalex {
testevalex {concat test}
} {test}
test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex {
testevalex {concat test\063\062test}
} {test32test}
test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
| | | | 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 |
test parse-10.1 {Tcl_EvalTokens, simple text} testevalex {
testevalex {concat test}
} {test}
test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex {
testevalex {concat test\063\062test}
} {test32test}
test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
testevalex {concat [expr {2 + 6}]}
} {8}
test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex {
unset -nocomplain a
list [catch {testevalex {concat xxx[expr $a]}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
set a hello
testevalex {concat $a}
} {hello}
test parse-10.6 {Tcl_EvalTokens, array variables} testevalex {
unset -nocomplain a
set a(12) 46
testevalex {concat $a(12)}
} {46}
test parse-10.7 {Tcl_EvalTokens, array variables} testevalex {
unset -nocomplain a
set a(12) 46
testevalex {concat $a(1[expr {3 - 1}])}
} {46}
test parse-10.8 {Tcl_EvalTokens, array variables} testevalex {
unset -nocomplain a
list [catch {testevalex {concat $x($a)}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.9 {Tcl_EvalTokens, array variables} testevalex {
unset -nocomplain a
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
unset -nocomplain abc
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
| | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
unset -nocomplain abc
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
test parse-13.6 {Tcl_ParseVar memory leak} -constraints {testparsevar memory} -setup {
proc getbytes {} {
return [lindex [split [memory info] \n] 3 3]
}
} -body {
set a() foo
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
|
| ︙ | ︙ |
Changes to tests/parseExpr.test.
1 2 3 4 | # This file contains a collection of tests for the procedures in the # file tclCompExpr.c. 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 |
# This file contains a collection of tests for the procedures in the
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body {
testexprparser \u043f -1
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body {
testexprparser in\u0433(0) -1
} -returnCodes error -match glob -result {missing operand*}
# cleanup
cleanupTests
return
| > > > > > > > > | 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body {
testexprparser \u043f -1
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body {
testexprparser in\u0433(0) -1
} -returnCodes error -match glob -result {missing operand*}
test parseExpr-23.1 {TIP 582: comments} -constraints testexprparser -body {
testexprparser "7 # * 8 " -1
} -result {- {} 0 subexpr 7 1 text 7 0 {}}
test parseExpr-23.2 {TIP 582: comments} -constraints testexprparser -body {
testexprparser "7 #\n* 8 " -1
} -result {- {} 0 subexpr {7 #
*} 5 operator # 0 subexpr 7 1 text 7 0 subexpr * 1 text * 0 {}}
# cleanup
cleanupTests
return
|
Changes to tests/parseOld.test.
1 2 3 4 5 6 7 8 | # Commands covered: set (plus basic command syntax). Also tests the # procedures in the file tclOldParse.c. This set of tests is an old # one that predates the new 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. # | | | | > | | | > | | 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 |
# Commands covered: set (plus basic command syntax). Also tests the
# procedures in the file tclOldParse.c. This set of tests is an old
# one that predates the new 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.
# 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.
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 testwordend [llength [info commands testwordend]]
testConstraint testbytestring [llength [info commands testbytestring]]
# Save the argv value for restoration later
set savedArgv $argv
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
format %s $b
]b
set a
} a22b
test parseOld-4.4 {command substitution} {
set a 7.7
| | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
format %s $b
]b
set a
} a22b
test parseOld-4.4 {command substitution} {
set a 7.7
if {[catch {expr {int($a)}}]} {set a foo}
set a
} 7.7
# Variable substitution.
test parseOld-5.1 {variable substitution} {
set a 123
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
test parseOld-13.1 {comments at the end of a bracketed script} {
set x "[
expr 1+1
# skip this!
]"
} {2}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
test parseOld-13.1 {comments at the end of a bracketed script} {
set x "[
expr 1+1
# skip this!
]"
} {2}
test parseOld-15.1 {TclScriptEnd procedure} {
info complete {puts [
expr 1+1
#this is a comment ]}
} {0}
test parseOld-15.2 {TclScriptEnd procedure} {
info complete "abc\\\n"
|
| ︙ | ︙ |
Changes to tests/pid.test.
1 2 3 4 5 6 | # Commands covered: pid # # 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 |
# Commands covered: pid
#
# 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-1995 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
|
| ︙ | ︙ |
Changes to tests/pkgMkIndex.test.
1 2 3 4 5 6 7 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # 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 |
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set fullPkgPath [makeDirectory pkg]
namespace eval pkgtest {
# Namespace for procs we can discard
}
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
#
# Results:
# Returns a list, in "array set/get" format, where the keys are the package
# name and version (in the form "$name:$version"), and the values the rest
# of the command line.
proc pkgtest::parseIndex { filePath } {
| | | | | | | | | | | | | 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 |
#
# Results:
# Returns a list, in "array set/get" format, where the keys are the package
# name and version (in the form "$name:$version"), and the values the rest
# of the command line.
proc pkgtest::parseIndex { filePath } {
# create a child interpreter, where we override "package ifneeded"
set child [interp create]
if {[catch {
$child eval {
rename package package_original
proc package { args } {
if {[lindex $args 0] eq "ifneeded"} {
set pkg [lindex $args 1]
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
} else {
return [package_original {*}$args]
}
}
array set ::PKGS {}
}
set dir [file dirname $filePath]
$child eval {set curdir [pwd]}
$child eval [list cd $dir]
$child eval [list set dir $dir]
$child eval [list source [file tail $filePath]]
$child eval {cd $curdir}
# Create the list in sorted order, so that we don't get spurious
# errors because the order has changed.
array set P {}
foreach {k v} [$child eval {array get ::PKGS}] {
set P($k) $v
}
set PKGS ""
foreach k [lsort [array names P]] {
lappend PKGS $k $P($k)
}
} err opts]} {
set ei [dict get $opts -errorinfo]
set ec [dict get $opts -errorcode]
catch {interp delete $child}
error $ei $ec
}
interp delete $child
return $PKGS
}
# pkgtest::createIndex --
#
# Runs pkg_mkIndex for the given directory and set of patterns. This
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
# This package is split into two files, to test packages that are split over
# multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
namespace export p2-1
}
proc pkg2::p2-1 { num } {
| | | | 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 |
# This package is split into two files, to test packages that are split over
# multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
namespace export p2-1
}
proc pkg2::p2-1 { num } {
return [expr {$num * 2}]
}
} [file join pkg pkg2_a.tcl]
makeFile {
# This package is required by pkg1.
# This package is split into two files, to test packages that are split over
# multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
namespace export p2-2
}
proc pkg2::p2-2 { num } {
return [expr {$num * 3}]
}
} [file join pkg pkg2_b.tcl]
test pkgMkIndex-4.1 {split package} {
pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
makeFile {
package provide pkg3 1.0
namespace eval pkg3 {
namespace export p3-1 p3-2
}
proc pkg3::p3-1 { num } {
| | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
makeFile {
package provide pkg3 1.0
namespace eval pkg3 {
namespace export p3-1 p3-2
}
proc pkg3::p3-1 { num } {
return {[expr {$num * 2}]}
}
proc pkg3::p3-2 { num } {
return {[expr {$num * 3}]}
}
} [file join pkg pkg3.tcl]
test pkgMkIndex-6.1 {pkg1 requires pkg3} {
pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 |
# requires circ1 to give us a circularity.
package require circ3 1.0
package provide circ2 1.0
namespace eval circ2 {
namespace export c2-1 c2-2
}
proc circ2::c2-1 { num } {
| | | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
# requires circ1 to give us a circularity.
package require circ3 1.0
package provide circ2 1.0
namespace eval circ2 {
namespace export c2-1 c2-2
}
proc circ2::c2-1 { num } {
return [expr {$num * [circ3::c3-1]}]
}
proc circ2::c2-2 { num } {
return [expr {$num * [circ3::c3-2]}]
}
} [file join pkg circ2.tcl]
makeFile {
# This package is required by circ2, and in turn requires circ1. This closes
# the circularity.
package require circ1 1.0
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 |
set x [file join [file dirname [info nameofexecutable]] dltest \
pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
testConstraint $dll [file exists $x]
if {[testConstraint $dll]} {
makeFile {
| | | | | 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 |
set x [file join [file dirname [info nameofexecutable]] dltest \
pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
testConstraint $dll [file exists $x]
if {[testConstraint $dll]} {
makeFile {
# This package provides pkga, which is also provided by a DLL.
package provide pkga 1.0
proc pkga_neq { x } {
return [expr {! [pkgq_eq $x]}]
}
} [file join pkg pkga.tcl]
file copy -force $x $fullPkgPath
}
testConstraint exec [llength [info commands ::exec]]
test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so we can
# delete the file and not get stuck because we're holding a reference to
# it.
set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
exec [interpreter] << $cmd
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so we can
# delete the file and not get stuck because we're holding a reference to
# it.
#
# This test depends on context from prior test, so repeat it.
set script \
|
| ︙ | ︙ |
Changes to tests/platform.test.
1 2 3 4 5 6 | # The file tests the tcl_platform variable and platform package. # # 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 |
# The file tests the tcl_platform variable and platform package.
#
# 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 © 1999 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.5
namespace eval ::tcl::test::platform {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
# This is not how [variable] works. See TIP 276.
#variable ::tcl_platform
namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
package require tcltests
testConstraint testCPUID [llength [info commands testcpuid]]
testConstraint testlongsize [llength [info commands testlongsize]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
|
| ︙ | ︙ |
Changes to tests/proc-old.test.
1 2 3 4 5 6 7 8 9 | # Commands covered: proc, return, global # # This file, proc-old.test, includes the original set of tests for Tcl's # proc, return, and global commands. There is now a new file proc.test # that contains tests for the tclProc.c source file. # # 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 |
# Commands covered: proc, return, global
#
# This file, proc-old.test, includes the original set of tests for Tcl's
# proc, return, and global commands. There is now a new file proc.test
# that contains tests for the tclProc.c source file.
#
# 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-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {rename t1 ""}
catch {rename foo ""}
proc tproc {} {return a; return b}
test proc-old-1.1 {simple procedure call and return} {tproc} a
proc tproc x {
set x [expr {$x + 1}]
return $x
}
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
test proc-old-1.3 {simple procedure call and return} {
proc tproc {} {return foo}
} {}
test proc-old-1.4 {simple procedure call and return} {
|
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
set x {}
proc tproc {} {} ;# body is shared with x
list [tproc] [append x foo]
} {{} foo}
test proc-old-2.1 {local and global variables} {
proc tproc x {
| | | | | | 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 |
set x {}
proc tproc {} {} ;# body is shared with x
list [tproc] [append x foo]
} {{} foo}
test proc-old-2.1 {local and global variables} {
proc tproc x {
set x [expr {$x + 1}]
return $x
}
set x 42
list [tproc 6] $x
} {7 42}
test proc-old-2.2 {local and global variables} {
proc tproc x {
set y [expr {$x + 1}]
return $y
}
set y 18
list [tproc 6] $y
} {7 18}
test proc-old-2.3 {local and global variables} {
proc tproc x {
global y
set y [expr {$x + 1}]
return $y
}
set y 189
list [tproc 6] $y
} {7 7}
test proc-old-2.4 {local and global variables} {
proc tproc x {
global y
return [expr {$x + $y}]
}
set y 189
list [tproc 6] $y
} {195 189}
catch {unset _undefined_}
test proc-old-2.5 {local and global variables} {
proc tproc x {
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
} 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
| | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
} 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 ""}
::tcltest::cleanupTests
return
|
Changes to tests/proc.test.
1 2 3 4 5 6 7 8 9 | # This file contains tests for the tclProc.c source file. Tests appear in the # same order as the C code that they test. The set of tests is currently # incomplete since it includes only new tests, in particular tests for code # changed for the addition of Tcl namespaces. Other procedure-related tests # appear in other test files such as proc-old.test. # # 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 |
# This file contains tests for the tclProc.c source file. Tests appear in the
# same order as the C code that they test. The set of tests is currently
# incomplete since it includes only new tests, in particular tests for code
# changed for the addition of Tcl namespaces. Other procedure-related tests
# appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
testConstraint memory [llength [info commands memory]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
|
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
[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)} {
| | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
[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)"
}
} -result {formal parameter "a(1)" is an array element}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup {
catch {rename p ""}
} -body {
proc p {b:a b::a} {
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
catch {rename {a b c} {}}
catch {unset msg}
catch {rename p ""}
catch {rename t ""}
# Note that the test require that procedures whose body is used to create
| | | | | | | | | | | | | | | | | | | | | 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 |
catch {rename {a b c} {}}
catch {unset msg}
catch {rename p ""}
catch {rename t ""}
# Note that the test require that procedures whose body is used to create
# procbody objects must be executed before the tcl::procbodytest::proc command is
# executed, so that the Proc struct is populated correctly (CompiledLocals are
# added at compile time).
test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body {
proc p x {return "$x:$x"}
set rv [p P]
tcl::procbodytest::proc t x p
lappend rv [t T]
} -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {P:P T:T}
test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body {
proc p x {
set y [string tolower $x]
return "$x:$y"
}
set rv [p P]
tcl::procbodytest::proc t x p
lappend rv [t T]
} -constraints tcl::test -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {P:p T:t}
test proc-4.3 {TclCreateProc, procbody obj, too many args} -body {
proc p x {
set y [string tolower $x]
return "$x:$y"
}
set rv [p P]
tcl::procbodytest::proc t {x x1 x2} p
lappend rv [t T]
} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1}
test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body {
proc p {x y z} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
tcl::procbodytest::proc t {x x1 z} p
lappend rv [t S T U]
} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body}
test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body {
proc p {x y {z Z}} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
tcl::procbodytest::proc t {x y z} p
lappend rv [t S T U]
} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body {
proc p {x y z} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
tcl::procbodytest::proc t {x y {z Z}} p
lappend rv [t S T U]
} -returnCodes error -constraints tcl::test -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body {
proc p {x y {z Z}} {
set v [join [list $x $y $z]]
set w [string tolower $v]
return "$v:$w"
}
set rv [p P Q R]
tcl::procbodytest::proc t {x y {z ZZ}} p
lappend rv [t S T U]
} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex $lines 3 3
}
proc px x {
set y [string tolower $x]
return "$x:$y"
}
px x
} -constraints {tcl::test memory} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
tcl::procbodytest::proc tx x px
set tmp $end
set end [getbytes]
}
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
unset -nocomplain end i tmp leakedBytes
} -result 0
test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test {
tcl::procbodytest::check
} 1
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
proc p args {} ; # this will be bytecompiled into t
proc t {} {
set res {}
set a 0
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
} -cleanup {
namespace delete ugly
} -result 4
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
set lambda x
lappend lambda {set a 1}
| | | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
} -cleanup {
namespace delete ugly
} -result 4
test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
set lambda x
lappend lambda {set a 1}
interp create child
child eval [list apply $lambda foo]
interp delete child
unset lambda
} {}
test proc-7.5 {[631b4c45df] Crash in argument processing} {
binary scan A c val
proc foo [list [list from $val]] {}
rename foo {}
|
| ︙ | ︙ |
Changes to tests/process.test.
1 2 3 4 5 6 | # process.test -- # # This file contains a collection of tests for the tcl::process ensemble. # 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 |
# process.test --
#
# This file contains a collection of tests for the tcl::process ensemble.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 2017 Frederic Bonnet
# 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::*
}
# Utilities
file delete [set path(test-signalfile) [makeFile {} test-signalfile]]
set path(test-signalfile2) [makeFile {} test-signalfile2]
# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted)
|
| ︙ | ︙ |
Changes to tests/pwd.test.
1 2 3 4 5 6 | # Commands covered: pwd # # 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 |
# Commands covered: pwd
#
# 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-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test pwd-1.1 {simple pwd} {
catch pwd
} 0
test pwd-1.2 {simple pwd} {
expr {[string length [pwd]]>0}
} 1
test pwd-2.1 {pwd takes no args} -body {
pwd foobar
} -returnCodes error -result "wrong \# args: should be \"pwd\""
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/reg.test.
1 2 3 4 5 6 7 8 9 | # reg.test -- # # 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. # (Don't panic if you are seeing this as part of the reg distribution # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # | | | | > | | 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 |
# reg.test --
#
# 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.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright © 1998, 1999 Henry Spencer. All rights reserved.
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]]
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp [llength [info commands testregexp]]
::tcltest::testConstraint localeRegexp 0
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
set constraints [TestConstraints $flags]
set f [TestFlags $flags]
set infoflags [TestInfoFlags $flags]
set ccmd [list testregexp -about {*}$f $re]
set nsub [expr {[llength $args] - 1}]
| | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
set constraints [TestConstraints $flags]
set f [TestFlags $flags]
set infoflags [TestInfoFlags $flags]
set ccmd [list testregexp -about {*}$f $re]
set nsub [expr {[llength $args] - 1}]
if {$nsub < 0} {
# didn't tell us number of subexps
set ccmd "lreplace \[$ccmd\] 0 0"
set info [list $infoflags]
} else {
set info [list $nsub $infoflags]
}
set ecmd [list testregexp {*}$f $re $target]
|
| ︙ | ︙ | |||
622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
| > | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectError 13.17.1 - {a\ux} EESCAPE
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
|
| ︙ | ︙ |
Changes to tests/regexp.test.
1 2 3 4 5 6 | # Commands covered: regexp, regsub # # 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 |
# Commands covered: regexp, regsub
#
# 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 © 1998 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain foo
testConstraint exec [llength [info commands exec]]
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexp-3.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexp-4.1 {-nocase option to regexp} {
regexp -nocase foo abcFOo
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
| > > > > > > > > > > > | 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 |
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexp-3.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexp-3.8a {-indices by multi-byte utf-8} {
regexp -inline -indices {(\w+)-(\w+)} \
"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"
} {{0 10} {0 3} {5 10}}
test regexp-3.8b {-indices by multi-byte utf-8, from -start position} {
list\
[regexp -inline -indices -start 3 {(\w+)-(\w+)} \
"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \
[regexp -inline -indices -start 4 {(\w+)-(\w+)} \
"gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"]
} {{{3 10} {3 3} {5 10}} {}}
test regexp-4.1 {-nocase option to regexp} {
regexp -nocase foo abcFOo
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
} -result {1 1}
test regexp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
} -result {1 3}
test regexp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
} -result {0}
test regexp-15.7 {regexp -start, double option} -body {
regexp -start 2 -start 0 a abc
} -result 1
test regexp-15.8 {regexp -start, double option} -body {
regexp -start 0 -start 2 a abc
} -result 0
test regexp-15.9 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexp-15.10 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
} -result {1 1 3}
test regexp-15.11 {regexp -start, over end of string} -body {
set x NA
list [regexp -start 2 {.*} ab x] $x
} -result {1 {}}
test regexp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} -result {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
} -result {0 hello}
test regexp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
} -result {0 hello}
test regexp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} -result {5 /a/b/c/d/e 3 ab/c/d/e}
test regexp-16.5 {regsub -start, double option} -body {
list [regsub -start 2 -start 0 a abc c x] $x
} -result {1 cbc}
test regexp-16.6 {regsub -start, double option} -body {
list [regsub -start 0 -start 2 a abc c x] $x
} -result {0 abc}
test regexp-16.7 {regexp -start, end relative index} -body {
list [regsub -start end a aaa b x] $x
} -result {0 aaa}
test regexp-16.8 {regexp -start, end relative index} -body {
list [regsub -start end-1 a aaa b x] $x
} -result {1 aab}
test regexp-16.9 {regsub -start and -all} -body {
set foo {}
list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo
} -result {2 a|xxx|b|xx|}
test regexp-16.10 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo
} -result {2 a|xxx|b|xx|}
test regexp-16.11 {regsub -start and -all} -body {
set foo {}
list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo
} -result {1 axxxb|xx|}
test regexp-16.12 {regsub -start} -body {
set foo {}
list [regsub -start 4 x+ axxxbxx |&| foo] $foo
} -result {1 axxxb|xx|}
test regexp-16.13 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.14 {regsub -start} -body {
set foo {}
list [regsub -start 1 a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.15 {regsub -start and -all} -body {
set foo {}
list [regsub -start 2 -all a+ "xy" & foo] $foo
} -result {0 xy}
test regexp-16.16 {regsub -start} -body {
set foo {}
list [regsub -start 2 a+ "xy" & foo] $foo
} -result {0 xy}
test regexp-16.17 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all y+ "xy" & foo] $foo
} -result {1 xy}
test regexp-16.18 {regsub -start} -body {
set foo {}
list [regsub -start 1 y+ "xy" & foo] $foo
} -result {1 xy}
test regexp-16.19 {regsub -start} -body {
set foo {}
list [regsub -start -1 a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.20 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^$} {} & foo] $foo
} -result {0 {}}
test regexp-16.21 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^.*$} abc & foo] $foo
} -result {0 abc}
test regexp-16.22 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -all -start 1 {^.*$} abc & foo] $foo
} -result {0 abc}
test regexp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 |
test regexp-19.2 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
set expected "\0a\0hel\0a\0lo\0a\0"
string equal $result $expected
} 1
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
test regexp-19.2 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
set expected "\0a\0hel\0a\0lo\0a\0"
string equal $result $expected
} 1
test regexp-20.1 {regsub shared object shimmering} -body {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} -body {
eval regexp -about abc
} -result {0 {}}
test regexp-21.1 {regsub works with empty string} -body {
regsub -- ^ {} foo
} -result {foo}
test regexp-21.2 {regsub works with empty string} -body {
regsub -- \$ {} foo
} -result {foo}
test regexp-21.3 {regsub works with empty string offset} -body {
regsub -start 0 -- ^ {} foo
} -result {foo}
test regexp-21.4 {regsub works with empty string offset} -body {
regsub -start 0 -- \$ {} foo
} -result {foo}
test regexp-21.5 {regsub works with empty string offset} -body {
regsub -start 3 -- \$ {123} foo
} -result {123foo}
test regexp-21.6 {regexp works with empty string} -body {
regexp -- ^ {}
} -result {1}
test regexp-21.7 {regexp works with empty string} -body {
regexp -start 0 -- ^ {}
} -result {1}
test regexp-21.8 {regexp works with empty string offset} -body {
regexp -start 3 -- ^ {123}
} -result {0}
test regexp-21.9 {regexp works with empty string offset} -body {
regexp -start 3 -- \$ {123}
} -result {1}
test regexp-21.10 {multiple matches handle newlines} {
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"
test regexp-21.12 {multiple matches handle newlines} {
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
test regexp-26.1 {matches start of line 1 time} {
regexp -all -inline -- {^a+} "aab\naaa"
} {aa}
test regexp-26.2 {matches start of line(s) 2 times} {
regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
| | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
test regexp-26.1 {matches start of line 1 time} {
regexp -all -inline -- {^a+} "aab\naaa"
} {aa}
test regexp-26.2 {matches start of line(s) 2 times} {
regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
test regexp-26.3 {effect of -line -all and -start} -body {
list \
[regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \
} -result {{aa aaa} aaa aaa aaa}
# No regexp-26.4
test regexp-26.5 {match length 0, match length 1} {
regexp -all -inline -line -- {^b*} "a\nb"
} {{} b}
test regexp-26.6 {non reporting capture group} {
regexp -all -inline -line -- {^(?:a+|b)} "aab\naaa"
} {aa aaa}
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
1 2 3 4 5 6 | # Commands covered: regexp, regsub # # 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 |
# Commands covered: regexp, regsub
#
# 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 © 1998 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
| | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexpComp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
} -result {1 1}
test regexpComp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexpComp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexpComp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
} -result {1 3}
test regexpComp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
} -result {0}
test regexpComp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} -result {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
} -result {0 hello}
test regexpComp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
} -result {0 hello}
test regexpComp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} -result {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-17.1 {regexp -inline} -body {
regexp -inline b ababa
} -result {b}
test regexpComp-17.2 {regexp -inline} -body {
regexp -inline (b) ababa
} -result {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexpComp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexpComp-17.5 {regexp -inline no matches} {
|
| ︙ | ︙ |
Changes to tests/registry.test.
1 2 3 4 5 6 7 8 9 | # registry.test -- # # This file contains a collection of tests for the registry command. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. # | | | | | > | 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 |
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright © 1997 Sun Microsystems, Inc. All rights reserved.
# Copyright © 1998-1999 Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::regver [package require registry 1.3.5]
}]} {
testConstraint reg 1
}
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
|
| ︙ | ︙ | |||
669 670 671 672 673 674 675 |
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" -time
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
| | | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" -time
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
test registry-12.4 {BroadcastValue} -constraints {win reg notWine} -body {
registry broadcast {Environment}
} -result {1 0}
test registry-12.5 {BroadcastValue} -constraints {win reg notWine} -body {
registry b {}
} -result {1 0}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# tcl-indent-level: 4
# fill-column: 78
# End:
|
Changes to tests/remote.tcl.
1 2 3 4 5 6 | # This file contains Tcl code to implement a remote server that can be # used during testing of Tcl socket code. This server is used by some # of the tests in socket.test. # # Source this file in the remote server you are using to test Tcl against. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # This file contains Tcl code to implement a remote server that can be # used during testing of Tcl socket code. This server is used by some # of the tests in socket.test. # # Source this file in the remote server you are using to test Tcl against. # # Copyright © 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. # Initialize message delimitor # Initialize command array |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
if {[info exists env(serverPort)]} {
set serverPort $env(serverPort)
}
}
if {![info exists serverPort]} {
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -port [lindex $argv $i]] == 0} {
| | | | | | 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 |
if {[info exists env(serverPort)]} {
set serverPort $env(serverPort)
}
}
if {![info exists serverPort]} {
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -port [lindex $argv $i]] == 0} {
if {$i < $argc - 1} {
set serverPort [lindex $argv [expr {$i + 1}]]
}
break
}
}
}
if {![info exists serverPort]} {
set serverPort 2048
}
if {![info exists serverAddress]} {
if {[info exists env(serverAddress)]} {
set serverAddress $env(serverAddress)
}
}
if {![info exists serverAddress]} {
for {set i 0} {$i < $argc} {incr i} {
if {[string compare -address [lindex $argv $i]] == 0} {
if {$i < $argc - 1} {
set serverAddress [lindex $argv [expr {$i + 1}]]
}
break
}
}
}
if {![info exists serverAddress]} {
set serverAddress 0.0.0.0
|
| ︙ | ︙ |
Changes to tests/rename.test.
1 2 3 4 5 6 | # Commands covered: rename # # 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 |
# Commands covered: rename
#
# 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 Sun Microsystems, Inc.
# 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.
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 testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
|
| ︙ | ︙ |
Changes to tests/resolver.test.
1 2 3 4 5 6 | # This test collection covers some unwanted interactions between command # literal sharing and the use of command resolvers (per-interp) which cause # command literals to be re-used with their command references being invalid # in the reusing context. 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 |
# This test collection covers some unwanted interactions between command
# literal sharing and the use of command resolvers (per-interp) which cause
# command literals to be re-used with their command references being invalid
# in the reusing context. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
#
# 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 testinterpresolver [llength [info commands testinterpresolver]]
test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
testinterpresolver up
namespace eval ::ns1 {
proc z {} { return Z }
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | # The test resolver-3.1* test bad interactions of resolvers on the "global" # (per interp) literal pools. A resolver might resolve a cmd literal depending # on a context differently, whereas the cmd literal sharing assumed that the # namespace containing the literal solely determines the resolved cmd (and is # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
# The test resolver-3.1* test bad interactions of resolvers on the "global"
# (per interp) literal pools. A resolver might resolve a cmd literal depending
# on a context differently, whereas the cmd literal sharing assumed that the
# namespace containing the literal solely determines the resolved cmd (and is
# resolver-agnostic).
#
# In order to make the test cases for the per-interpreter cmd literal pool
# reproducable and to minimize interactions between test cases, we use a child
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
interp command resolver,
|
| ︙ | ︙ |
Changes to tests/result.test.
1 2 3 4 5 6 | # This file tests the routines in tclResult.c. # # 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 |
# This file tests the routines in tclResult.c.
#
# 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 © 1997 Sun Microsystems, Inc.
# 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.
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]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]]
testConstraint testseterrorcode [llength [info commands testseterrorcode]]
testConstraint testreturn [llength [info commands testreturn]]
|
| ︙ | ︙ |
Added tests/safe-stock.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 |
# safe-stock.test --
#
# This file contains tests for safe Tcl that were previously in the file
# safe.test, and use files and packages of stock Tcl 8.7 to perform the tests.
# These files may be changed or disappear in future revisions of Tcl, for
# example package opt will eventually be removed.
#
# The tests are replaced in safe.tcl with tests that use files provided in the
# tests directory. Test numbering is for comparison with similar tests in
# safe.test.
#
# Sourcing this file into tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# The defunct package http 1.0 was convenient for testing package loading.
# - This file, safe-stock.test, uses packages opt and (from cookiejar)
# tcl::idna to provide alternative tests based on stock Tcl packages.
# - These are tests 7.1 7.2 7.4 9.11 9.13
# - Tests 7.[124], 9.1[13] use "package require opt".
# - Tests 9.1[13] also use "package require tcl::idna".
# - The corresponding tests in safe.test use example packages provided in
# subdirectory auto0 of the tests directory, which are independent of any
# changes made to the packages provided with Tcl.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
foreach i [interp children] {
interp delete $i
}
# When using package opt for testing positive/negative package search:
# - The directory location and the error message depend on whether
# and how the package is installed.
# Error message for test 7.2 for "package require opt".
if {[string match *zipfs:/* [info library]]} {
# pkgIndex.tcl is in [info library]
# file to be sourced is in [info library]/opt*
set pkgOptErrMsg {permission denied}
} else {
# pkgIndex.tcl and file to be sourced are
# both in [info library]/opt*
set pkgOptErrMsg {can't find package opt}
}
# Directory of opt for tests 7.4, 9.10, 9.12 for "package require opt".
if {[file exists [file join [info library] opt0.4]]} {
# Installed files in lib8.7/opt0.4
set pkgOptDir opt0.4
} elseif {[file exists [file join [info library] opt]]} {
# Installed files in zipfs, or source files used by "make test"
set pkgOptDir opt
} else {
error {cannot find opt library}
}
# Directory of cookiejar for tests 9.10, 9.12 for "package require tcl::idna".
if {[file exists [file join [info library] cookiejar0.2]]} {
# Installed files in lib8.7/cookiejar0.2
set pkgJarDir cookiejar0.2
} elseif {[file exists [file join [info library] cookiejar]]} {
# Installed files in zipfs, or source files used by "make test"
set pkgJarDir cookiejar
} else {
error {cannot find cookiejar library}
}
set SaveAutoPath $::auto_path
set ::auto_path [info library]
set TestsDir [file normalize [file dirname [info script]]]
set PathMapp {}
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 un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
# high level general test
test safe-stock-7.1 {tests that everything works at high level, uses pkg opt} -setup {
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
} -match glob -result 0.4.*
test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses pkg opt} -setup {
} -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 {
} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\
{TCLLIB */dummy/unixlike/test/path} -- {}"
test safe-stock-7.4 {tests specific path and positive search, uses pkg opt} -setup {
} -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 {
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\
{TCLLIB * TCLLIB/OPTDIR} -- {}}
# 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, uses pkg opt and tcl::idna} -setup {
} -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
} -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, uses pkg opt and tcl::idna} -setup {
} -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}}
# 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 $tcl_library $pkgOptDir]} path4]
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
} -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*}}
set ::auto_path $SaveAutoPath
unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp
rename mapList {}
rename mapAndSortList {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Added tests/safe-stock86.test.
Added tests/safe-zipfs.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 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 |
# safe-zipfs.test --
#
# This file contains tests for safe Tcl that test its compatibility with the
# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison
# with similar tests in safe.test that do not use the zipfs file system.
#
# Sourcing this file into tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# 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.
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 $ZipMountPoint [file join $TestsDir auto-files.zip]
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}
# testing that nested and statics do what is advertised (we use a
# package - tcl::test - but it might be absent if we're in standard tclsh)
testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
# 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; zipfs} -setup {
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
} -match glob -result 1.2.3
test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup {
} -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 {
} -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; zipfs} -setup {
} -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 {
} -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); zipfs} -setup {
} -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
} -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); zipfs} -setup {
} -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
} -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; zipfs} -setup {
} -body {
# For complete correspondence to safe-stock87-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
} -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; zipfs} -setup {
} -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
} -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; zipfs} -setup {
} -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
} -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; 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 {
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
} -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; stale data case 1; 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 {
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
} -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; stale data case 0; 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 {
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
} -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; stale data case 3; 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 {
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
} -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; stale data case 2 (worst case); 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 {
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
} -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.
# cleanup
set ::auto_path $SaveAutoPath
zipfs unmount ${ZipMountPoint}
unset SaveAutoPath TestsDir ZipMountPoint PathMapp
rename mapList {}
rename mapAndSortList {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/safe.test.
1 2 3 4 5 6 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, and # using safe interpreters. 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 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 |
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading, and
# using safe interpreters. Sourcing this file into tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# The defunct package http 1.0 was convenient for testing package loading.
# - Tests that used http are replaced here with tests that use example packages
# provided in subdirectory auto0 of the tests directory, which are independent
# of any changes made to the packages provided with Tcl itself.
# - These are tests 7.1 7.2 7.4 9.11 9.13
# - Tests 5.* test the example packages themselves before they
# are used to test Safe Base interpreters.
# - Alternative tests using stock packages of Tcl 8.7 are in file
# safe-stock.test.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# 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.
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 PathMapp [list $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 un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
# testing that nested and statics do what is advertised (we use a static
# package - tcl::test - but it might be absent if we're in standard tclsh)
testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
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} -returnCodes error -body {
safe::interpCreate -help
} -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.3 {safe::interpInit syntax} -returnCodes error -body {
safe::interpInit -noStatics
} -result {bad value "-noStatics" for parameter
child name () name of the child}
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
# Disabled this test. It tests nothing sensible. [Bug 999612]
# interp aliases
} ""
test safe-2.2 {creating interpreters, should have no aliases} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a aliases
} -cleanup {
safe::interpDelete a
# This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
# is regrettable and should be removed at the next major revision.
} -result ""
test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup {
catch {safe::interpDelete a}
} -body {
interp create a -safe
lsort [a aliases]
} -cleanup {
|
| ︙ | ︙ | |||
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 |
} -result {}
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
safe::interpDelete a
} -result ""
test safe-4.2 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a alias exit safe::interpDelete a
a eval exit
} -result ""
test safe-4.5 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::interpCreate a
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
| > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > > > | > > > > > > | > > > > > > > > > > > > < > > > > > > > > > > > > | > | | 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 |
} -result {}
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
safe::interpDelete a
# This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
# is regrettable and should be removed at the next major revision.
} -result ""
test safe-4.2 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a alias exit safe::interpDelete a
a eval exit
# This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
# is regrettable and should be removed at the next major revision.
} -result ""
test safe-4.5 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::interpCreate a
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
# The old test "safe-5.1" has been moved to "safe-stock-9.8".
# A replacement test using example files is "safe-9.8".
# Tests 5.* test the example files before using them to test safe interpreters.
unset -nocomplain path
test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir 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-5.2 {example tclIndex commands, negative test in parent interpreter} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir 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-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir 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-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}
test safe-5.6 {example modules packages, test in parent interpreter, append to path} -setup {
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]
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 interps 'information leak'
proc SafeEval {script} {
# Helper procedure that ensures the safe interp is cleaned up even if
# there is a failure in the script.
set SafeInterp [interp create -safe]
catch {$SafeInterp eval $script} msg opts
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 179 180 181 182 |
if {[testConstraint win]} {
set r [lsearch -all -inline -not -exact $r "debug"]
}
set r [lsearch -all -inline -not -exact $r "threaded"]
lsort $r
} {byteOrder engine pathSeparator platform pointerSize wordSize}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
# high level general test
| > > | > > > > | | | < > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > | | < | | | | | | < < > > > > > < > > | > < > > | > < > > | > < > > | > < > > | > > > > < > > > > > > > | | | 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 |
if {[testConstraint win]} {
set r [lsearch -all -inline -not -exact $r "debug"]
}
set r [lsearch -all -inline -not -exact $r "threaded"]
lsort $r
} {byteOrder engine pathSeparator platform pointerSize wordSize}
rename SafeEval {}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
# high level general test
# Use example packages not http1.0 etc
test safe-7.1 {tests that everything works at high level} -setup {
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
} -match glob -result 1.2.3
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup {
} -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 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 {
} -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 {tests specific path and positive search} -setup {
} -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 {
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\
{TCLLIB * TESTSDIR/auto0/auto1} -- {}}
# test source control on file name
test safe-8.1 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source}
} -returnCodes error -cleanup {
safe::interpDelete $i
unset i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.2 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source a b c d e}
} -returnCodes error -cleanup {
safe::interpDelete $i
unset i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.3 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {lappend ::log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {$i eval {source .}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
rename safe-test-log {}
unset i log
} -result {1 {permission denied} {{ERROR for child a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {$i eval {source /abc/def}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
rename safe-test-log {}
unset i log
} -result {1 {permission denied} {{ERROR for child a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
# This tested filename == *.tcl or tclIndex, but that restriction was
# removed in 8.4a4 - hobbs
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
rename safe-test-log {}
unset i log
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
rename safe-test-log {}
unset i log
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
# This tested length of filename, but that restriction was removed in
# 8.4a4 - hobbs
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
safe::interpDelete $i
rename safe-test-log {}
unset i log
} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} emptyTest {
# Disabled this test. It was only useful for long unsupported
# Mac OS 9 systems. [Bug 860a9f1945]
} {}
test safe-8.9 {safe source and return} -setup {
set i "a"
set returnScript [makeFile {return "ok"} return.tcl]
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
$i eval [list source $token/[file tail $returnScript]]
} -cleanup {
catch {safe::interpDelete $i}
removeFile $returnScript
unset i
} -result ok
test safe-8.10 {safe source and return} -setup {
set i "a"
set returnScript [makeFile {return -level 2 "ok"} return.tcl]
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
$i eval [list apply {filename {
source $filename
error boom
}} $token/[file tail $returnScript]]
} -cleanup {
catch {safe::interpDelete $i}
removeFile $returnScript
unset i
} -result ok
test safe-9.1 {safe interps' deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
set res {}
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
list [interp eval $i exit] $res
} -cleanup {
catch {rename testDelHook {}}
unset i res
} -result {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
set res {}
set log {}
proc safe-test-log {str} {lappend ::log $str}
set prevlog [safe::setLogCmd]
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
# create an exception
error "being catched"
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
safe::setLogCmd safe-test-log
list [safe::interpDelete $i] $res $log
} -cleanup {
safe::setLogCmd $prevlog
catch {rename testDelHook {}}
rename safe-test-log {}
unset i log res
} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}}
test safe-9.3 {dual specification of statics} -returnCodes error -body {
safe::interpCreate -stat true -nostat
} -result {conflicting values given for -statics and -noStatics}
test safe-9.4 {dual specification of statics} {
# no error shall occur
safe::interpDelete [safe::interpCreate -stat false -nostat]
} {}
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 | [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 safe::interpConfigure $i] | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | 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 |
[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
safe::interpConfigure $i]
} -cleanup {
safe::interpDelete $i
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto}}
test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body {
# this test shall work, believed equivalent to 9.6
set i [safe::interpCreate \
-noStatics \
-nestedLoadOk \
-deleteHook {foo bar}]
safe::interpConfigure $i -accessPath /foo/bar
set a [safe::interpConfigure $i]
set b [safe::interpConfigure $i -aCCess]
set c [safe::interpConfigure $i -nested]
set d [safe::interpConfigure $i -statics]
set e [safe::interpConfigure $i -DEL]
safe::interpConfigure $i -accessPath /blah -statics 1
set f [safe::interpConfigure $i]
safe::interpConfigure $i -deleteHook toto -nosta -nested 0
set g [safe::interpConfigure $i]
list $a $b $c $d $e $f $g
} -cleanup {
safe::interpDelete $i
unset -nocomplain a b c d e f g i
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto}}
test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup {
} -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
} -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)} -setup {
} -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
} -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)} -setup {
} -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
} -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} -setup {
} -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
} -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, 9.10 without path auto0} -setup {
} -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
} -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} -setup {
} -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}}
# 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 $TestsDir auto0 auto1]} path4]
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
} -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} -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 {
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]]
# 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 $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
} -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; stale data case 1} -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 {
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]]
# 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 $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
} -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; stale data case 0} -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 {
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
} -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; stale data case 3} -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 {
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]]
# 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 $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]]
# 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 $TestsDir auto0 modules]
foreach path [lreverse $oldTm] {
tcl::tm::path add $path
}
safe::interpDelete $i
} -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; stale data case 2 (worst case)} -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 {
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]]
# 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 $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
} -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.
catch {teststaticpkg Safepkg1 0 0}
test safe-10.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i {load {} Safepkg1}} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1"
invoked from within
"interp eval $i {load {} Safepkg1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {permission denied (static package)}
test safe-10.3 {testing nested statics loading / no nested by default} -setup {
set i [safe::interpCreate]
} -constraints tcl::test -body {
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
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 {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_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 {} Safepkg1 x}} m o
dict get $o -errorinfo
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1 x"
invoked from within
"interp eval $i {interp create x; load {} Safepkg1 x}"}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
proc buildEnvironment {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
set testdir [makeDirectory deletethisdir]
set testdir2 [makeDirectory deletemetoo $testdir]
set testfile [makeFile {} $filename $testdir2]
}
#### New tests for Safe base glob, with patches @ Bug 2964715
test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
} -returnCodes error -cleanup {
safe::interpDelete $i
| > > > > > > > > > | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
proc buildEnvironment {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
set testdir [makeDirectory deletethisdir]
set testdir2 [makeDirectory deletemetoo $testdir]
set testfile [makeFile {} $filename $testdir2]
}
proc buildEnvironment2 {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
upvar 1 testdir3 testdir3 testfile2 testfile2
set testdir [makeDirectory deletethisdir]
set testdir2 [makeDirectory deletemetoo $testdir]
set testfile [makeFile {} $filename $testdir2]
set testdir3 [makeDirectory deleteme $testdir]
set testfile2 [makeFile {} $filename $testdir3]
}
#### New tests for Safe base glob, with patches @ Bug 2964715
test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob *
} -returnCodes error -cleanup {
safe::interpDelete $i
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
::safe::interpAddToAccessPath $i $testdir
$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
| | | > > > > > > > > > > > > > | | < | | 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 |
::safe::interpAddToAccessPath $i $testdir
$i eval \
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment pkgIndex.tcl
} -body {
set safeTD [::safe::interpAddToAccessPath $i $testdir]
::safe::interpAddToAccessPath $i $testdir2
mapList [list $safeTD EXPECTED] [$i eval [list \
glob -directory $safeTD -join * pkgIndex.tcl]]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {EXPECTED/deletemetoo/pkgIndex.tcl}
test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup {
set i [safe::interpCreate]
buildEnvironment2 pkgIndex.tcl
} -body {
set safeTD [::safe::interpAddToAccessPath $i $testdir]
::safe::interpAddToAccessPath $i $testdir2
::safe::interpAddToAccessPath $i $testdir3
mapAndSortList [list $safeTD EXPECTED] [$i eval [list \
glob -directory $safeTD -join * pkgIndex.tcl]]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl}
# See comments on lsort after test safe-9.20.
test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment notIndex.tcl
} -body {
set safeTD [::safe::interpAddToAccessPath $i $testdir]
::safe::interpAddToAccessPath $i $testdir2
$i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
} -cleanup {
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 734 735 |
::safe::interpAddToAccessPath $i $testdir
$i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
#### Test for the module path
| > | | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
::safe::interpAddToAccessPath $i $testdir
$i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
rename buildEnvironment2 {}
#### Test for the module 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
|
| ︙ | ︙ | |||
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 |
$i eval {
set d [format %c 126]
list [file join [file dirname $d] [file tail $d]]
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
} -result {./~}
test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval \
"file join \[file dirname ~$user\] \[file tail ~$user\]"]
} -cleanup {
safe::interpDelete $i
} -result {./~USER}
test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
set syntheticHOME [makeDirectory foo]
makeFile {} bar $syntheticHOME
set savedHOME $env(HOME)
set env(HOME) $syntheticHOME
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $syntheticHOME
$i eval {glob -nocomplain ~/*}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
removeDirectory $syntheticHOME
} -result {}
test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $~$tcl_platform(user)
$i eval [list glob -nocomplain ~$tcl_platform(user)/*]
} -cleanup {
safe::interpDelete $i
} -result {}
| > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | 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 |
$i eval {
set d [format %c 126]
list [file join [file dirname $d] [file tail $d]]
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
} -result {./~}
test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval \
"file join \[file dirname ~$user\] \[file tail ~$user\]"]
} -cleanup {
safe::interpDelete $i
unset user
} -result {./~USER}
test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
set syntheticHOME [makeDirectory foo]
makeFile {} bar $syntheticHOME
set savedHOME $env(HOME)
set env(HOME) $syntheticHOME
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $syntheticHOME
$i eval {glob -nocomplain ~/*}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
removeDirectory $syntheticHOME
unset savedHOME syntheticHOME
} -result {}
test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
set i [safe::interpCreate]
} -body {
::safe::interpAddToAccessPath $i $~$tcl_platform(user)
$i eval [list glob -nocomplain ~$tcl_platform(user)/*]
} -cleanup {
safe::interpDelete $i
} -result {}
test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup {
set savedHOME $env(HOME)
set env(HOME) /foo/bar
set i [safe::interpCreate]
} -body {
$i eval {
set d [format %c 126]
file join {$p(:0:)} $d
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
} -result {~}
test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup {
set savedHOME $env(HOME)
set env(HOME) /foo/bar
set i [safe::interpCreate]
} -body {
$i eval {
set d [format %c 126]
file join {$p(:0:)/foo/bar} $d
}
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
unset savedHOME
} -result {~}
test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]]
} -cleanup {
safe::interpDelete $i
unset user
} -result {~USER}
test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup {
set i [safe::interpCreate]
set user $tcl_platform(user)
} -body {
string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]]
} -cleanup {
safe::interpDelete $i
unset user
} -result {~USER}
# cleanup
set ::auto_path $SaveAutoPath
unset SaveAutoPath TestsDir PathMapp
unset -nocomplain path
rename mapList {}
rename mapAndSortList {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/scan.test.
1 2 3 4 5 6 | # Commands covered: scan # # 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 |
# Commands covered: scan
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# procedure that returns the range of integers
proc int_range {} {
set MAX_INT [expr {[format %u -2]/2}]
|
| ︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
} -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-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 {
| > > > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
} -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-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 {
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
| > > > > > | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-6.8 {disallow diget separator in floating-point} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c
} -result {3 3.14 2.35 98.6}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
|
| ︙ | ︙ |
Changes to tests/security.test.
1 2 3 4 5 6 7 8 | # security.test -- # # Functionality covered: this file contains a collection of tests for the auto # loading and namespaces. # # 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 |
# security.test --
#
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# If this proc becomes invoked, then there is a bug
proc BUG {args} {
set ::BUG 1
|
| ︙ | ︙ |
Changes to tests/set-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: set, unset, array # # This file includes the original set of tests for Tcl's set command. # Since the set command is now compiled, a new set of tests covering # the new implementation is in the file "set.test". 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 |
# Commands covered: set, unset, array
#
# This file includes the original set of tests for Tcl's set command.
# Since the set command is now compiled, a new set of tests covering
# the new implementation is in the file "set.test". 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-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
proc ignore args {}
# Simple variable operations.
|
| ︙ | ︙ |
Changes to tests/set.test.
1 2 3 4 5 6 | # Commands covered: set # # 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 |
# Commands covered: set
#
# 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 © 1996 Sun Microsystems, Inc.
# 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.
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 testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
test set-1.1 {TclCompileSetCmd: missing variable name} {
|
| ︙ | ︙ |
Changes to tests/socket.test.
1 2 3 4 5 6 | # Commands tested in this file: socket. # # 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 | # Commands tested in this file: socket. # # 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 © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # Running socket tests with a remote server: # ------------------------------------------ # |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | # either in Tcl or in the environment; if they are, it attempts to connect to # the server. If the connection is successful, the tests using the remote # server will be performed; otherwise, it will attempt to start the remote # server (via exec) on platforms that support this, on the local host, # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. | | | | > > > | > | > > | 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 |
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
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]]
::tcltest::loadTestedCommands
# A bad interaction between socket creation, macOS, and unattended CI
# environments make this whole file impractical to run; too many weird hangs.
if {[info exists ::env(MAC_CI)]} {
return
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint exec [llength [info commands exec]]
testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}]
testConstraint notWinCI [expr {
$tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} {
# firstly try dynamic port via server-socket(0):
set port 0x7fffffff
catch {
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
}
}
}
# Some tests are run only if we are doing testing against a remote server.
testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer
if {!$doTestsWithRemoteServer} {
| | | 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"
}
}
#
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
}
}
proc getPort sock {
lindex [fconfigure $sock -sockname] 2
}
# ----------------------------------------------------------------------
test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
| > > > > > | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 |
}
}
proc getPort sock {
lindex [fconfigure $sock -sockname] 2
}
# Some tests in this file are known to hang *occasionally* on OSX; stop the
# worst offenders.
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# Here "Windows" means derived platforms as Cygwin or Msys2 too.
testConstraint notWindows [expr {![regexp {^(Windows|MSYS|CYGWIN)} $::tcl_platform(os)]}]
# ----------------------------------------------------------------------
test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 |
proc readpipe {pipe} {
while {![string is integer [set ::done [gets $pipe]]]} {}
}
vwait ::done
close $f
set ::done
} 0
| | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
proc readpipe {pipe} {
while {![string is integer [set ::done [gets $pipe]]]} {}
}
vwait ::done
close $f
set ::done
} 0
test socket_$af-2.13 {Bug 1758a0b603} {socket stdio notWine} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set server [socket -server accept 0]
puts [lindex [chan configure $server -sockname] 2]
proc accept { client host port } {
chan configure $client -blocking 0 -buffering line -buffersize 1
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
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}
| | | | | 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 |
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}
}
return {couldn't open socket: port number too high}
} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
if {![catch {socket -server dodo 21} 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-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
proc myHandler {msg options} {
variable x $msg
}
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
file delete $path(script)
} -body {
set f [open $path(script) w]
puts $f [list set localhost $localhost]
puts $f {
gets stdin port
socket $localhost $port
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
proc accept {s a p} {expr {10 / 0}}
set s [socket -server accept -myaddr $localhost 0]
puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
|
| ︙ | ︙ | |||
1535 1536 1537 1538 1539 1540 1541 |
fileevent $c readable "readlittle $c"
vwait done
list $spurious $len $done
} -cleanup {
after cancel $timer
sendCommand {close $server}
} -result {0 2690 1}
| | | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 |
fileevent $c readable "readlittle $c"
vwait done
list $spurious $len $done
} -cleanup {
after cancel $timer
sendCommand {close $server}
} -result {0 2690 1}
test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer notWine] -setup {
set counter 0
set done 0
set port [sendCommand {
set server [socket -server accept 0]
proc accept {s a p} {
after idle close $s
}
|
| ︙ | ︙ | |||
1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
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]
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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 (immediatelly 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 commiting 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
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 2 "== stop / $::count =="
unset -nocomplain ::count ::testmode ::parent ::helper
}
}
test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body {
transf_test {transfer} 1000
} -result 1000 -constraints [list socket supported_$af thread]
test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body {
transf_test {transfer helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body {
transf_test {parent-close} 100
} -result 100 -constraints [list socket supported_$af thread]
test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body {
transf_test {parent-close helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
catch {rename transf_parent {}}
rename transf_test {}
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
|
| ︙ | ︙ | |||
1994 1995 1996 1997 1998 1999 2000 |
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} \
| | | 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 |
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} \
|
| ︙ | ︙ | |||
2282 2283 2284 2285 2286 2287 2288 |
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} \
| | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
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
|
| ︙ | ︙ | |||
2329 2330 2331 2332 2333 2334 2335 |
set x
} -cleanup {
close $s
unset x s
} -result {connection refused}
test socket-14.13 {testing writable event when quick failure} \
| | | 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
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
# Test only for windows as socket -async 255.255.255.255 fails
# directly on unix
# The following connect should fail very quickly
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
} -cleanup {
catch {close $ssock}
catch {close $csock1}
catch {close $csock2}
} -result {}
test socket-14.19 {tip 456 -- introduce the -reuseport option} \
| | | 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 |
} -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 {
|
| ︙ | ︙ |
Changes to tests/source.test.
1 2 3 4 5 6 | # Commands covered: source # # 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 |
# Commands covered: source
#
# 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.
# Copyright © 1998-2000 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (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.
if {[catch {package require tcltest 2.5}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
|
| ︙ | ︙ |
Changes to tests/split.test.
1 2 3 4 5 6 | # Commands covered: split # # 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 |
# Commands covered: split
#
# 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.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test split-1.1 {basic split commands} {
split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test split-1.2 {basic split commands} {
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
| | | > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
split "a\U1F4A9b" {}
} -result "a \U1F4A9 b"
test split-1.16 {basic split commands} -body {
split "a\U1F4A9b" \U1F4A9
} -result "a b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
|
| ︙ | ︙ |
Changes to tests/stack.test.
1 2 3 4 5 6 | # Tests that the stack size is big enough for the application. # # 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 |
# Tests that the stack size is big enough for the application.
#
# 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 © 1998-2000 Ajuba Solutions.
#
# 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::*
}
# Note that a failure in this test may result in a crash of the executable.
test stack-1.1 {maxNestingDepth reached on infinite recursion} -body {
# do this in a sub process in case it segfaults
exec [interpreter] << {
proc recurse {} { recurse }
|
| ︙ | ︙ |
Changes to tests/string.test.
1 2 3 4 5 6 | # Commands covered: string # # 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 41 42 |
# Commands covered: string
#
# 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 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001 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.
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]]
# Helper commands to test various optimizations, code paths, and special cases.
proc makeByteArray {s} {binary format a* $s}
proc makeUnicode {s} {lindex [regexp -inline .* $s] 0}
proc makeList {args} {return $args}
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
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]
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
proc foo {str i} {
if {"yes" == "no"} { string never called but complains here }
string index $str $i
}
foo abc 0
} a
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
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"}}
test string-2.2.$noComp {string compare, bad args} {
list [catch {run {string compare a b c}} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-2.3.$noComp {string compare, bad args} {
list [catch {run {string compare -length -nocase str1 str2}} msg] $msg
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
test string-2.11.2.$noComp {string compare, unicode} {
run {string compare \334 \xFC}
} -1
test string-2.11.3.$noComp {string compare, unicode} {
run {string compare \334\334\334\374\374 \334\334\334\334\334}
} 1
test string-2.12.$noComp {string compare, high bit} {
| | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
test string-2.11.2.$noComp {string compare, unicode} {
run {string compare \334 \xFC}
} -1
test string-2.11.3.$noComp {string compare, unicode} {
run {string compare \334\334\334\374\374 \334\334\334\334\334}
} 1
test string-2.12.$noComp {string compare, high bit} {
# This test will fail if the underlying comparison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
run {string compare "\x80" "@"}
# Nb this tests works also in utf-8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test string-2.13.$noComp {string compare -nocase} {
run {string compare -nocase abcde abdef}
} -1
test string-2.13.1.$noComp {string compare -nocase} {
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
} 1
test string-3.7.$noComp {string equal -nocase} {
run {string equal -nocase abcde abcde}
} 1
test string-3.8.$noComp {string equal with length, unequal strings} {
run {string equal -length 2 abc abde}
} 1
| | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
} 1
test string-3.7.$noComp {string equal -nocase} {
run {string equal -nocase abcde abcde}
} 1
test string-3.8.$noComp {string equal with length, unequal strings} {
run {string equal -length 2 abc abde}
} 1
test string-3.9.$noComp {string equal, not enough args} {
list [catch {run {string equal a}} msg] $msg
} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
test string-3.10.$noComp {string equal, bad args} {
list [catch {run {string equal a b c}} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test string-3.11.$noComp {string equal, bad args} {
list [catch {run {string equal -length -nocase str1 str2}} msg] $msg
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 |
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
| | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
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-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?}}
test string-4.3.$noComp {string first, too many args} {
list [catch {run {string first a b 5 d}} msg] $msg
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
} 4
test string-4.10.$noComp {string first, unicode} {
run {string first \u7266 abc\u7266x}
} 3
test string-4.11.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 3}
} 3
| | | | | | | | | | | | | | | | | | | | | | 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 |
} 4
test string-4.10.$noComp {string first, unicode} {
run {string first \u7266 abc\u7266x}
} 3
test string-4.11.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 3}
} 3
test string-4.12.$noComp {string first, start index} -body {
run {string first \u7266 abc\u7266x 4}
} -result -1
test string-4.13.$noComp {string first, start index} -body {
run {string first \u7266 abc\u7266x end-2}
} -result 3
test string-4.14.$noComp {string first, negative start index} -body {
run {string first b abc -1}
} -result 1
test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} -body {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057E ;# character with two-byte encoding in utf-8
run {string first % %#$uchar$uchar#$uchar$uchar#% 3}
} -result 8
test string-4.16.$noComp {string first, normal string vs pure unicode string} -body {
set s hello
regexp ll $s m
# Representation checks are canaries
run {list [representationpoke $s] [representationpoke $m] \
[string first $m $s]}
} -result {{string 1} {string 0} 2}
test string-4.17.$noComp {string first, corner case} -body {
run {string first a aaa 4294967295}
} -result {-1}
test string-4.18.$noComp {string first, corner case} -body {
run {string first a aaa -1}
} -result {0}
test string-4.19.$noComp {string first, corner case} -body {
run {string first a aaa end-5}
} -result {0}
test string-4.20.$noComp {string last, corner case} -body {
run {string last a aaa 4294967295}
} -result {2}
test string-4.21.$noComp {string last, corner case} -body {
run {string last a aaa -1}
} -result {-1}
test string-4.22.$noComp {string last, corner case} {
run {string last a aaa end-5}
} {-1}
test string-5.1.$noComp {string index} {
list [catch {run {string index}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
} b
test string-5.10.$noComp {string index, unicode} {
run {string index abc\u7266d 4}
} d
test string-5.11.$noComp {string index, unicode} {
run {string index abc\u7266d 3}
} \u7266
| | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
} b
test string-5.10.$noComp {string index, unicode} {
run {string index abc\u7266d 4}
} d
test string-5.11.$noComp {string index, unicode} {
run {string index abc\u7266d 3}
} \u7266
test string-5.12.$noComp {string index, unicode over char length, under byte length} -body {
run {string index \334\374\334\374 6}
} -result {}
test string-5.13.$noComp {string index, bytearray object} {
run {string index [binary format a5 fuz] 0}
} f
test string-5.14.$noComp {string index, bytearray object} {
run {string index [binary format I* {0x50515253 0x52}] 3}
} S
test string-5.15.$noComp {string index, bytearray object} {
|
| ︙ | ︙ | |||
498 499 500 501 502 503 504 |
} -match glob -result {1 {*invalid octal number*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
| | | | | | | | 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 |
} -match glob -result {1 {*invalid octal number*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} -body {
run {string index [binary format I* {0x50515253 0x52}] 20}
} -result {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body {
run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
} -result [list \U100000 {} b]
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] }
return [expr {$int-1}]
}
test string-6.1.$noComp {string is, not enough args} {
list [catch {run {string is}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.2.$noComp {string is, not enough args} {
list [catch {run {string is alpha}} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.3.$noComp {string is, bad args} {
list [catch {run {string is alpha -failin str}} msg] $msg
} {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}}
test string-6.4.$noComp {string is, too many args} {
list [catch {run {string is alpha -failin var -strict str more}} msg] $msg
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA}
} 1
test string-6.82.$noComp {string is wordchar, false} {
list [run {string is wordchar -fail var abcd.ef}] $var
} {0 4}
test string-6.83.$noComp {string is wordchar, unicode false} {
list [run {string is wordchar -fail var abc\x80def}] $var
} {0 3}
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
} {0 87}
test string-6.131.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
catch {rename largest_int {}}
| | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
} {0 87}
test string-6.131.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
catch {rename largest_int {}}
test string-7.1.$noComp {string last, not enough args} {
list [catch {run {string last a}} msg] $msg
} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.2.$noComp {string last, bad args} {
list [catch {run {string last a b c}} msg] $msg
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3.$noComp {string last, too many args} {
list [catch {run {string last a b c d}} msg] $msg
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
test string-9.6.$noComp {string length, bytearray object} {
run {string length [binary format a5 foo]}
} 5
test string-9.7.$noComp {string length, bytearray object} {
run {string length [binary format I* {0x50515253 0x52}]}
} 8
| | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 |
test string-9.6.$noComp {string length, bytearray object} {
run {string length [binary format a5 foo]}
} 5
test string-9.7.$noComp {string length, bytearray object} {
run {string length [binary format I* {0x50515253 0x52}]}
} 8
test string-10.1.$noComp {string map, not enough args} {
list [catch {run {string map}} msg] $msg
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.2.$noComp {string map, bad args} {
list [catch {run {string map {a b} abba oops}} msg] $msg
} {1 {bad option "a b": must be -nocase}}
test string-10.3.$noComp {string map, too many args} {
list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg
|
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 |
run {string map {lon foob longstring bar} longlon}
} foobgfoob
test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
run {string map $a $a}
} {b b}
| | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
run {string map {lon foob longstring bar} longlon}
} foobgfoob
test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
run {string map $a $a}
} {b b}
test string-11.1.$noComp {string match, not enough args} {
list [catch {run {string match a}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2.$noComp {string match, too many args} {
list [catch {run {string match a b c d}} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.3.$noComp {string match} {
run {string match abc abc}
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
| | > > > > > > > > > > > > > > | 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 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 {} b]
test string-12.24.$noComp {bignum index arithmetic} -setup {
proc demo {i j} {string range fubar $i $j}
} -cleanup {
rename demo {}
} -body {
demo 2 0+0x10000000000000000
} -result bar
test string-12.25.$noComp {bignum index arithmetic} -setup {
proc demo {i j} {string range fubar $i $j}
} -cleanup {
rename demo {}
} -body {
demo 0x10000000000000000-0xffffffffffffffff 3
} -result uba
test string-13.1.$noComp {string repeat} {
list [catch {run {string repeat}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2.$noComp {string repeat} {
list [catch {run {string repeat abc 10 oops}} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
|
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 |
list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
| | | | | | 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 |
list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
test string-14.6.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 7 1000}
} -result {abcdefg}
test string-14.7.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 end}
} {abcdefghij}
test string-14.8.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 9}
} {abcdefghijklmnop}
test string-14.9.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 2}
} {defghijklmnop}
test string-14.10.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 -2}
} {abcdefghijklmnop}
test string-14.11.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 1000 1010}
} -result {abcdefghijklmnop}
test string-14.12.$noComp {string replace} {
run {string replace abcdefghijklmnop -100 end}
} {}
test string-14.13.$noComp {string replace} {
list [catch {run {string replace abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14.$noComp {string replace} {
|
| ︙ | ︙ | |||
1646 1647 1648 1649 1650 1651 1652 1653 |
}
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
| > > > | | 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 |
}
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}
} aed
test string-15.1.$noComp {string tolower not enough args} {
list [catch {run {string tolower}} msg] $msg
} {1 {wrong # args: should be "string tolower string ?first? ?last?"}}
test string-15.2.$noComp {string tolower bad args} {
list [catch {run {string tolower a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-15.3.$noComp {string tolower too many args} {
list [catch {run {string tolower ABC 1 end oops}} msg] $msg
|
| ︙ | ︙ | |||
1739 1740 1741 1742 1743 1744 1745 |
} "Abcabc\xE7\xE7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01F3BCabc\xC7\xE7}
} "\u01F2bcabc\xE7\xE7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
| | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
} "Abcabc\xE7\xE7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01F3BCabc\xC7\xE7}
} "\u01F2bcabc\xE7\xE7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} utf16 {
run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
[string totitle a\U118c0c 3 3]}
} [list a\U118a0c a\U118c0C a\U118c0C]
test string-18.1.$noComp {string trim} {
list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 1816 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | 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 |
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} {testbytestring} {
set result {}
set a [testbytestring \xC0\x80\xA0]
set b foo$a
set m [list \x00 U \xA0 V [testbytestring \xA0] W]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \x00}]]
lappend result [string map $m [run {string trimleft $b fox}]]
lappend result [string map $m [run {string trimleft $b fo\x00}]]
lappend result [string map $m [run {string trim $b fox}]]
lappend result [string map $m [run {string trim $b fo\x00}]]
} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]]
test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} {testbytestring} {
set result {}
set a [testbytestring \xE8\xA0]
set b foo$a
set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \xE8}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]]
lappend result [string map $m [run {string trimright $b \xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]]
lappend result [string map $m [run {string trimright $b \xE8\xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]]
lappend result [string map $m [run {string trimright $b \u0000}]]
} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV]
test string-21.1.$noComp {string wordend} -body {
list [catch {run {string wordend a}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.2.$noComp {string wordend} -body {
list [catch {run {string wordend a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.3.$noComp {string wordend} -body {
list [catch {run {string wordend a gorp}} msg] $msg
} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-21.4.$noComp {string wordend} -body {
run {string wordend abc. -1}
} -result 3
test string-21.5.$noComp {string wordend} -body {
run {string wordend abc. 100}
} -result 4
test string-21.6.$noComp {string wordend} -body {
run {string wordend "word_one two three" 2}
} -result 8
test string-21.7.$noComp {string wordend} -body {
run {string wordend "one .&# three" 5}
} -result 6
test string-21.8.$noComp {string wordend} -body {
run {string worde "x.y" 0}
} -result 1
test string-21.9.$noComp {string wordend} -body {
run {string worde "x.y" end-1}
} -result 2
test string-21.10.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\xC7de fg" 0}
} -result 6
test string-21.11.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\uC700de fg" 0}
} -result 6
test string-21.12.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u203Fde fg" 0}
} -result 6
test string-21.13.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u2045de fg" 0}
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-21.15.$noComp {string wordend, unicode} -body {
run {string wordend "\U1D7CA\U1D7CA abc" 0}
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body {
run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 8
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} -body {
list [catch {run {string wordstart a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} -body {
list [catch {run {string wordstart a gorp}} msg] $msg
} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-22.5.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" 400}
} -result 8
test string-22.6.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" 2}
} -result 0
test string-22.7.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" -2}
} -result 0
test string-22.8.$noComp {string wordstart} -body {
run {string wordstart "one .*&^ three" 6}
} -result 6
test string-22.9.$noComp {string wordstart} -body {
run {string wordstart "one two three" 4}
} -result 4
test string-22.10.$noComp {string wordstart} -body {
run {string wordstart "one two three" end-5}
} -result 7
test string-22.11.$noComp {string wordstart, unicode} -body {
run {string wordstart "one tw\xC7o three" 7}
} -result 4
test string-22.12.$noComp {string wordstart, unicode} -body {
run {string wordstart "ab\uC700\uC700 cdef ghi" 12}
} -result 10
test string-22.13.$noComp {string wordstart, unicode} -body {
run {string wordstart "\uC700\uC700 abc" 8}
} -result 3
test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body {
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
run {string index $demo [string wordstart $demo 10]}
} -result g
test string-22.15.$noComp {string wordstart, unicode} -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 0}
} -result 0
test string-22.16.$noComp {string wordstart, unicode} -constraints utf16 -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 10}
} -result 5
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
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} {
|
| ︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 |
list [run {string is list -failindex x { {b c}d e}}] $x
} {0 2}
test string-25.14.$noComp {string is list} {
set x {}
list [run {string is list -failindex x "\uABCD {b c}d e"}] $x
} {0 2}
| | | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
list [run {string is list -failindex x { {b c}d e}}] $x
} {0 2}
test string-25.14.$noComp {string is list} {
set x {}
list [run {string is list -failindex x "\uABCD {b c}d e"}] $x
} {0 2}
test string-26.1.$noComp {tcl::prefix, not enough args} -body {
tcl::prefix match a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"}
test string-26.2.$noComp {tcl::prefix, bad args} -body {
tcl::prefix match a b c
} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
test string-26.2.1.$noComp {tcl::prefix, empty table} -body {
tcl::prefix match {} foo
|
| ︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 |
# Use the same objects in all places
catch {
tcl::prefix match -error $error $table $item
}
}
} -constraints memory -result {0}
| | | 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 |
# 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 {
tcl::prefix all a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.3.$noComp {tcl::prefix all, bad args} -body {
tcl::prefix all "{}x" str2
|
| ︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 |
test string-27.9.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} p
} {}
test string-27.10.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} {}
} {apa aska appa}
| | | 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 |
test string-27.9.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} p
} {}
test string-27.10.$noComp {tcl::prefix all} {
tcl::prefix all {apa aska appa} {}
} {apa aska appa}
test string-28.1.$noComp {tcl::prefix longest, not enough args} -body {
tcl::prefix longest a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.2.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.3.$noComp {tcl::prefix longest, bad args} -body {
tcl::prefix longest "{}x" str2
|
| ︙ | ︙ | |||
2248 2249 2250 2251 2252 2253 2254 |
test string-28.11.$noComp {tcl::prefix longest} {
tcl::prefix longest {{} bska appa} {}
} {}
test string-28.12.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa {} appa} {}
} {}
test string-28.13.$noComp {tcl::prefix longest} {
| | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
test string-28.11.$noComp {tcl::prefix longest} {
tcl::prefix longest {{} bska appa} {}
} {}
test string-28.12.$noComp {tcl::prefix longest} {
tcl::prefix longest {apa {} appa} {}
} {}
test string-28.13.$noComp {tcl::prefix longest} {
# Test utf-8 handling
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
test string-29.1.$noComp {string cat, no arg} {
run {string cat}
} ""
test string-29.2.$noComp {string cat, single arg} {
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 |
test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
[makeShared [makeUnicode _]]}
} 0123_
test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
run {tcl::string::insert [makeList a b c] 1 zzzzzz}
} {azzzzzz b c}
test string-32.1.$noComp {string is dict} {
string is dict {a b c d}
} 1
test string-32.1a.$noComp {string is dict} {
string is dict {a b c}
} 0
| > > > > > > > | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 |
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 {
run {tcl::string::insert abcd $i xyz}
} -cleanup {
unset i
} -result abxyzcd
test string-32.1.$noComp {string is dict} {
string is dict {a b c d}
} 1
test string-32.1a.$noComp {string is dict} {
string is dict {a b c}
} 0
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
1 2 3 4 5 6 7 8 | # Commands covered: none # # This file contains tests for the procedures in tclStringObj.c that implement # the Tcl type manager for the string type. # # 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 |
# Commands covered: none
#
# This file contains tests for the procedures in tclStringObj.c that implement
# the Tcl type manager for the string type.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1995-1997 Sun Microsystems, Inc.
# 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.
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 testobj [llength [info commands testobj]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint tip389 [expr {[string length \U010000] == 2}]
testConstraint nodep [info exists tcl_precision]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first >= 0}]
} 1
test stringObj-2.1 {Tcl_NewStringObj} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [teststringobj set 1 abcd]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
|
| ︙ | ︙ |
Changes to tests/subst.test.
1 2 3 4 5 6 | # Commands covered: subst # # 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 |
# Commands covered: subst
#
# 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 © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
#
# 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]]
test subst-1.1 {basics} -returnCodes error -body {
subst
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
subst -no bar
} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
subst -bogus bar
} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
set x 123
| | | | | | | | 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 |
subst -no bar
} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
subst -bogus bar
} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
set x 123
subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
set x 123
subst -nocommands {abc $x [expr {1 + 2}] \\\x41}
} {abc 123 [expr {1 + 2}] \A}
test subst-7.6 {switches} {
set x 123
subst -novariables {abc $x [expr {1 + 2}] \\\x41}
} {abc $x 3 \A}
test subst-7.7 {switches} {
set x 123
subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41}
} {abc $x [expr {1 + 2}] \\\x41}
test subst-8.1 {return in a subst} {
subst {foo [return {x}; bogus code] bar}
} {foo x bar}
test subst-8.2 {return in a subst} {
subst {foo [return x ; bogus code] bar}
} {foo x bar}
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
set script [makeFile {
proc demo {string} {
subst $string
}
demo name2
} subst13.tcl]
} -body {
| | | | | | | | | 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 |
set script [makeFile {
proc demo {string} {
subst $string
}
demo name2
} subst13.tcl]
} -body {
interp create child
child eval [list source $script]
interp delete child
interp create child
child eval {
set count 400
while {[incr count -1]} {
lappend bloat [expr {rand()}]
}
}
child eval [list source $script]
interp delete child
} -cleanup {
removeFile subst13.tcl
}
test subst-13.2 {Test for segfault} -body {
subst {[}
} -returnCodes error -result * -match glob
|
| ︙ | ︙ |
Changes to tests/switch.test.
1 2 3 4 5 6 | # Commands covered: switch # # 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 |
# Commands covered: switch
#
# 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 © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test switch-1.1 {simple patterns} {
switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4}
} 1
test switch-1.2 {simple patterns} {
|
| ︙ | ︙ |
Changes to tests/tailcall.test.
1 2 3 4 5 6 | # Commands covered: tailcall # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # | | | | | | 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 |
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright © 2008 Miguel Sofer.
#
# 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 testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
|
| ︙ | ︙ |
Changes to tests/tcltest.test.
1 2 3 4 | # 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 |
# 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 © 1998-1999 Scriptics Corporation.
# Copyright © 2000 Ajuba Solutions
# All rights reserved.
# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself. Ditto on things like [verbose].
#
# It would be better to have the -body of the tests run the tcltest
# commands in a child interp so the [test] being tested would not
# interfere with the [test] doing the testing.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcltest::test {
namespace import ::tcltest::*
makeFile {
package require tcltest 2.5
namespace import ::tcltest::test
test a-1.0 {test a} {
list 0
} {0}
test b-1.0 {test b} {
list 1
} {0}
|
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
} {1 0}
# -verbose, implicit & explicit testing of [verbose]
| | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
} {1 0}
# -verbose, implicit & explicit testing of [verbose]
proc child {msgVar args} {
upvar 1 $msgVar msg
interp create [namespace current]::i
# Fake the child interp into dumping output to a file
i eval {namespace eval ::tcltest {}}
i eval "set tcltest::outputChannel\
\[[list open [set of [makeFile {} output]] w]]"
i eval "set tcltest::errorChannel\
\[[list open [set ef [makeFile {} error]] w]]"
i eval [list set argv0 [lindex $args 0]]
i eval [list set argv [lrange $args 1 end]]
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
| | | | | | | | | | | 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 |
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
set result [child msg test.tcl]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
set result [child msg test.tcl -verbose 'b']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
set result [child msg test.tcl -verbose 'p']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
set result [child msg test.tcl -verbose 's']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
set result [child msg test.tcl -verbose 'ps']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
set result [child msg test.tcl -verbose 'psb']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
set result [child msg test.tcl -verbose "pass skip body"]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose 't']
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.6a {tcltest -verbose 'start'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose start]
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.7 {tcltest::verbose} {
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
| | | | | | | | | | | | | | 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 |
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
set result [child msg test.tcl -verbose error]
list $result $msg
}
-result {errorInfo: foo.*errorCode: 9}
-match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
set result [child msg test.tcl -match a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
set result [child msg test.tcl -match b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
set result [child msg test.tcl -match c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
set result [child msg test.tcl -match {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}
test tcltest-3.5 {tcltest::match} {
-body {
set oldMatch [match]
match foo
set currentMatch [match]
match bar
set newMatch [match]
match $oldMatch
list $currentMatch $newMatch
}
-result {foo bar}
}
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
set result [child msg test.tcl -skip a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
set result [child msg test.tcl -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
set result [child msg test.tcl -skip c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
set result [child msg test.tcl -skip {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-4.6 {tcltest::skip} {
-body {
set oldSkip [skip]
skip foo
set currentSkip [skip]
skip bar
set newSkip [skip]
skip $oldSkip
list $currentSkip $newSkip
}
-result {foo bar}
}
# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
set result [child msg test.tcl -constraints knownBug -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
-body {
set r1 [testConstraint tcltestFakeConstraint]
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
# testConstraint knownBug $keepkb
# }
# -result {false knownBug knownBug}
#}
# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
set printerror [makeFile {
| | | | | | | 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 |
# testConstraint knownBug $keepkb
# }
# -result {false knownBug knownBug}
#}
# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
set printerror [makeFile {
package require tcltest 2.5
namespace import ::tcltest::*
puts [outputChannel] "a test"
::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/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrWin
-body {
child msg $printerror
return $msg
}
-result {a test.*a really}
-match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
child msg $printerror -outfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
child msg $printerror -errfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
child msg $printerror -outfile a.tmp -errfile b.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" b.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 \
[file exists a.tmp] [file delete a.tmp] \
[file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
removeFile efile
}
}
# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
| | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
removeFile efile
}
}
# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# child interp
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
}
}
removeFile test.tcl
# directory tests
set a [makeFile {
| | | | | | | | | | 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 |
}
}
removeFile test.tcl
# directory tests
set a [makeFile {
package require tcltest 2.5
tcltest::makeFile {} a.tmp
puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl]
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
file delete -force thisdirectorydoesnotexist
} -body {
child msg $a -tmpdir thisdirectorydoesnotexist
file exists [file join thisdirectorydoesnotexist a.tmp]
} -cleanup {
file delete -force thisdirectorydoesnotexist
} -result 1
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
child msg $a -tmpdir $tdiaf
return $msg
}
-result {*not a directory*}
-match glob
}
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
unix {
file attributes $notReadableDir -permissions 0o333
file attributes $notWriteableDir -permissions 0o555
}
default {
# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
child msg $a -tmpdir $notReadableDir
return $msg
}
-result {*not readable*}
-match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
-constraints {unixOrWin notRoot notFAT}
-body {
child msg $a -tmpdir $notWriteableDir
return $msg
}
-result {*not writeable*}
-match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
-constraints unixOrWin
-body {
child msg $a -tmpdir $normaldirectory
# The join is necessary because the message can be split on multiple
# lines
file exists [file join $normaldirectory a.tmp]
}
-cleanup {
catch {file delete [file join $normaldirectory a.tmp]}
}
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
| | | | | | 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 |
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
child msg $a -testdir thisdirectorydoesnotexist
return $msg
}
-match glob
-result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
child msg $a -testdir $tdiaf
return $msg
}
-match glob
-result {*not a directory*}
}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
-constraints {unix notRoot}
-body {
child msg $a -testdir $notReadableDir
return $msg
}
-match glob
-result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
-constraints unixOrWin
-body {
child msg $a -testdir $normaldirectory
# The join is necessary because the message can be split on multiple
# lines
list [string first "testdir: $normaldirectory" [join $msg]] \
[file exists [file join [temporaryDirectory] a.tmp]]
}
-cleanup {
file delete [file join [temporaryDirectory] a.tmp]
|
| ︙ | ︙ | |||
731 732 733 734 735 736 737 |
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
| | | | 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 |
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
child msg [file join [testsDirectory] all.tcl] -file d*.test
return $msg
} -cleanup {
testsDirectory $old
} -match regexp -result {dstring\.test}
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
child msg [file join [testsDirectory] all.tcl] \
-file d*.test -notfile dstring*
regexp {dstring\.test} $msg
} -cleanup {
testsDirectory $old
} -result 0
test tcltest-9.3 {matchFiles} {
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
set d [makeDirectory tmp]
makeDirectory foo $d
makeFile {} fee $d
file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
| | | | | | | | 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 |
test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
set d [makeDirectory tmp]
makeDirectory foo $d
makeFile {} fee $d
file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
child msg [file join [temporaryDirectory] all.tcl] -file f*
regexp {exiting with errors:} $msg
} -cleanup {
file delete [file join $d all.tcl]
removeFile fee $d
removeDirectory foo $d
removeDirectory tmp
} -result 0
# -preservecore, [preserveCore]
set mc [makeFile {
package require tcltest 2.5
namespace import ::tcltest::test
test makecore {make a core file} {
set f [open core w]
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
child msg $mc -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
child msg $mc -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
child msg $mc -preservecore 2
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrWin} {
child msg $mc -preservecore 3
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
# Removing this test. It makes no sense to test the ability of
# [preserveCore] to accept an invalid value that will cause errors
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
# }
# -result {foo foo}
#}
removeFile makecore.tcl
# -load, -loadfile, [loadScript], [loadFile]
set contents {
| | | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
# }
# -result {foo foo}
#}
removeFile makecore.tcl
# -load, -loadfile, [loadScript], [loadFile]
set contents {
package require tcltest 2.5
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrWin} {
child msg $loadfile -load xxx
return $msg
} {xxx}
# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} {
catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
list \
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
} single1.test $spd
makeFile {
unset foo
} single2.test $spd
set allfile [makeFile {
| | | | | 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 |
} single1.test $spd
makeFile {
unset foo
} single2.test $spd
set allfile [makeFile {
package require tcltest 2.5
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} all-single.tcl $spd]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrWin}
-body {
child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
return $msg
}
-result {Test file error: can't unset .foo.: no such variable}
-match regexp
}
test tcltest-14.2 {-singleproc - multiple process} {
-constraints {unixOrWin}
-body {
child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
return $msg
}
-result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
-match regexp
}
test tcltest-14.3 {singleProcess} {
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 |
# all.tcl files.
set dtd [makeDirectory dirtestdir]
set dtd1 [makeDirectory dirtestdir2.1 $dtd]
set dtd2 [makeDirectory dirtestdir2.2 $dtd]
set dtd3 [makeDirectory dirtestdir2.3 $dtd]
makeFile {
| | | | | | | | | | | 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 |
# all.tcl files.
set dtd [makeDirectory dirtestdir]
set dtd1 [makeDirectory dirtestdir2.1 $dtd]
set dtd2 [makeDirectory dirtestdir2.2 $dtd]
set dtd3 [makeDirectory dirtestdir2.3 $dtd]
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir]
runAllTests
} all.tcl $dtd
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
runAllTests
} all.tcl $dtd1
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2]
runAllTests
} all.tcl $dtd2
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
}
test tcltest-15.2 {-asidefromdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-asidefromdir dirtestdir2.3 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!$}
}
test tcltest-15.3 {-relateddir, non-existent dir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir [file join [temporaryDirectory] dirtestdir0] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {[^~]|dirtestdir[^2]}
}
test tcltest-15.4 {-relateddir, subdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
-constraints {unixOrWin}
-body {
if {[child msg \
[file join $dtd all.tcl] \
-relateddir "dirtestdir2.1 dirtestdir2.2" \
-asidefromdir dirtestdir2.2 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
set oldoptions $::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
# set this to { } instead of just {} to get around quirk in
# Windows env handling that removes empty elements from env array.
set ::env(TCLTEST_OPTIONS) { }
| | | | | | | | | | | | | | 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 |
set oldoptions $::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
# set this to { } instead of just {} to get around quirk in
# Windows env handling that removes empty elements from env array.
set ::env(TCLTEST_OPTIONS) { }
interp create child1
child1 eval [list set argv {-debug 2}]
child1 alias puts puts
interp create child2
child2 alias puts puts
} -cleanup {
interp delete child2
interp delete child1
if {$oldoptions eq "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
}
} -body {
child1 eval [package ifneeded tcltest [package provide tcltest]]
child1 eval tcltest::debug
set ::env(TCLTEST_OPTIONS) "-debug 3"
child2 eval [package ifneeded tcltest [package provide tcltest]]
child2 eval tcltest::debug
} -result {^3$} -match regexp -output\
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrWin} {
set result [child msg $printerror]
list $result [regexp "Error: a really short string" $msg] \
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
[regexp " \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
cd [workingDirectory]
removeFile printerror.tcl
|
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 |
} -result {^$} -output {foo is 2} -match regexp
# test all.tcl usage (runAllTests); simulate .test file failure, as well as
# crashes to determine whether or not these errors are logged.
set atd [makeDirectory alltestdir]
makeFile {
| | | | | 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 |
} -result {^$} -output {foo is 2} -match regexp
# test all.tcl usage (runAllTests); simulate .test file failure, as well as
# crashes to determine whether or not these errors are logged.
set atd [makeDirectory alltestdir]
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] alltestdir]
runAllTests
} all.tcl $atd
makeFile {
exit 1
} exit.test $atd
makeFile {
error "throw an error"
} error.test $atd
makeFile {
package require tcltest 2.5
namespace import -force tcltest::*
test foo-1.1 {foo} {
-body { return 1 }
-result {1}
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in child interp.
test tcltest-22.1 {runAllTests} {
-constraints {unixOrWin}
-body {
exec [interpreter] \
[file join $atd all.tcl] \
-verbose t -tmpdir [temporaryDirectory]
}
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
}
test tcltest-23.2 {removeFile} {
-setup {
set mfdir [file join [temporaryDirectory] mfdir]
file mkdir $mfdir
makeFile {} t1.tmp
makeFile {} et1.tmp $mfdir
| | | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
}
test tcltest-23.2 {removeFile} {
-setup {
set mfdir [file join [temporaryDirectory] mfdir]
file mkdir $mfdir
makeFile {} t1.tmp
makeFile {} et1.tmp $mfdir
if {![file exists [file join [temporaryDirectory] t1.tmp]] || \
![file exists [file join $mfdir et1.tmp]]} {
error "file creation didn't work"
}
}
-body {
removeFile t1.tmp
removeFile et1.tmp $mfdir
|
| ︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 |
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -output {*generated error; Return code was: 1*}
test tcltest-26.1 {Bug/RFE 1017151} -setup {
makeFile {
| | | | | | 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 |
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -output {*generated error; Return code was: 1*}
test tcltest-26.1 {Bug/RFE 1017151} -setup {
makeFile {
package require tcltest 2.5
set ::errorInfo "Should never see this"
tcltest::test tcltest-26.1.0 {
no errorInfo when only return code mismatch
} -body {
set x 1
} -returnCodes error -result 1
tcltest::cleanupTests
} test.tcl
} -body {
child msg [file join [temporaryDirectory] test.tcl]
return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- Return code should have been one of: 1
==== tcltest-26.1.0 FAILED*}
test tcltest-26.2 {Bug/RFE 1017151} -setup {
makeFile {
package require tcltest 2.5
set ::errorInfo "Should never see this"
tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
error "body error"
} -cleanup {
error "cleanup error"
} -result 1
tcltest::cleanupTests
} test.tcl
} -body {
child msg [file join [temporaryDirectory] test.tcl]
return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- errorInfo: body error
*
---- errorInfo(cleanup): cleanup error*}
|
| ︙ | ︙ |
Changes to tests/tcltests.tcl.
1 2 | #! /usr/bin/env tclsh | | | 1 2 3 4 5 6 7 8 9 10 |
#! /usr/bin/env tclsh
package require tcltest 2.5
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
testConstraint thread [
expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
|
| ︙ | ︙ |
Changes to tests/thread.test.
1 2 3 4 5 6 | # Commands covered: (test)thread # # 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 41 42 43 44 45 46 47 48 49 50 51 52 53 |
# Commands covered: (test)thread
#
# 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
#
# 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::*
}
# when thread::release is used, -wait is passed in order allow the thread to
# be fully finalized, which avoids valgrind "still reachable" reports.
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
package require tcltests
# Some tests require the testthread command
testConstraint testthread [expr {[info commands testthread] ne {}}]
set threadSuperKillScript {
rename catch ""
rename while ""
rename unknown ""
rename update ""
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] {
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
[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}}
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
[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 \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
[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}}
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
[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 \
[string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
|
| ︙ | ︙ |
Changes to tests/timer.test.
1 2 3 4 5 6 7 8 9 | # This file contains a collection of tests for the procedures in the # file tclTimer.c, which includes the "after" Tcl command. Sourcing # this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # 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 |
# This file contains a collection of tests for the procedures in the
# file tclTimer.c, which includes the "after" Tcl command. Sourcing
# this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# 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 © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
foreach i [after info] {
after cancel $i
}
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
set x before
after 300
update
return $x
} -result {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
| | | | | | | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
set x before
after 300
update
return $x
} -result {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
interp create child
child eval namespace export after
child eval namespace eval foo namespace import ::after
} -body {
child eval foo::after 1
child eval namespace origin foo::after
} -cleanup {
# Bug will cause crash here; would cause failure otherwise
interp delete child
} -result ::after
test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body {
set b ok
set a [after 0x100000001 {set b "after fired early"}]
after 100 set done 1
vwait done
|
| ︙ | ︙ |
Changes to tests/tm.test.
1 2 3 4 5 | # This file contains tests for the ::tcl::tm::* 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 |
# This file contains tests for the ::tcl::tm::* commands.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 2004 Donal K. Fellows.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test tm-1.1 {tm: path command exists} {
catch { ::tcl::tm::path }
info commands ::tcl::tm::path
} ::tcl::tm::path
|
| ︙ | ︙ |
Changes to tests/trace.test.
1 2 3 4 5 6 | # Commands covered: trace # # 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 |
# Commands covered: trace
#
# 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 Sun Microsystems, Inc.
# 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.
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 testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
| | | | | | 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
test trace-28.4 {exec traces in child with 'return -code error'} {
interp create child
interp alias child traceExecute {} traceExecute
set info {}
set res [interp eval child {
set info {}
set res {}
proc foo {} {
if {[catch {bar}]} {
return "error"
} else {
|
| ︙ | ︙ | |||
2225 2226 2227 2228 2229 2230 2231 |
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
list $res
}]
| | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
list $res
}]
interp delete child
lappend res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} enterstep
|
| ︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 |
} {1 {unknown command "thisdoesntexist"}}
test trace-28.10 {exec trace info nonsense} {
list [catch {trace remove execution} res] $res
} {1 {wrong # args: should be "trace remove execution name opList command"}}
test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
| | | | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
} {1 {unknown command "thisdoesntexist"}}
test trace-28.10 {exec trace info nonsense} {
list [catch {trace remove execution} res] $res
} {1 {wrong # args: should be "trace remove execution name opList command"}}
test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [expr {14 + 16}]}
} {{expr {14 + 16}} {expr {14 + 16}} {set stuff [expr {14 + 16}]} {set stuff 30}}
test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [info tclversion]}
} [concat {{info tclversion} {info tclversion} ::tcl::info::tclversion {::tcl::info::tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]]
test trace-29.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace deletetest {set stuff [info tclversion]}
} [info tclversion]
test trace-29.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
|
| ︙ | ︙ |
Changes to tests/unixFCmd.test.
1 2 3 4 5 6 | # This file tests the tclUnixFCmd.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 |
# This file tests the tclUnixFCmd.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.
#
# Copyright © 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.
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 testchmod [llength [info commands testchmod]]
# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
cleanup
}
test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td1/td2/td3
| | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
cleanup
}
test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td1/td2/td3
file attributes td1/td2 -permissions 0
file rename td1/td2/td3 td2
} -returnCodes error -cleanup {
file attributes td1/td2 -permissions 0o755
cleanup
} -result {error renaming "td1/td2/td3": permission denied}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir td1/td2
file mkdir td2
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unix notRoot} {
# can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir foo/bar
| | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unix notRoot} {
# can't make it happen
} {}
test unixFCmd-1.7 {TclpRenameFile: EXDEV} -setup {
cleanup
} -constraints {unix notRoot} -body {
file mkdir foo/bar
file attr foo -perm 0o40555
file rename foo/bar /tmp
} -returnCodes error -cleanup {
catch {file delete /tmp/bar}
catch {file attr foo -perm 0o40777}
catch {file delete -force foo}
} -match glob -result {*: permission denied}
test unixFCmd-1.8 {Checking EINTR Bug} {unix notRoot nonPortable} {
testalarm
after 2000
list [testgotsig] [testgotsig]
} {1 0}
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
file attributes foo.test -owner foozzz
} -result {could not set owner for file "foo.test": user "foozzz" does not exist}
test unixFCmd-17.1 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot} -body {
close [open foo.test w]
| | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
file attributes foo.test -owner foozzz
} -result {could not set owner for file "foo.test": user "foozzz" does not exist}
test unixFCmd-17.1 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot} -body {
close [open foo.test w]
list [file attributes foo.test -permissions 0] \
[file attributes foo.test -permissions]
} -cleanup {
file delete -force -- foo.test
} -result {{} 00000}
test unixFCmd-17.2 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot} -returnCodes error -body {
file attributes foo.test -permissions 0
} -result {could not set permissions for file "foo.test": no such file or directory}
test unixFCmd-17.3 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot} -body {
close [open foo.test w]
file attributes foo.test -permissions foo
} -cleanup {
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
set cd [pwd]
} -body {
# This test is nonPortable because SunOS generates a weird error
# message when the current directory isn't readable.
set nd $cd/tstdir
file mkdir $nd
cd $nd
| | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
set cd [pwd]
} -body {
# This test is nonPortable because SunOS generates a weird error
# message when the current directory isn't readable.
set nd $cd/tstdir
file mkdir $nd
cd $nd
file attributes $nd -permissions 0
pwd
} -returnCodes error -cleanup {
cd $cd
file attributes $nd -permissions 0o755
file delete $nd
} -match glob -result {error getting working directory name:*}
test unixFCmd-19.1 {GetReadOnlyAttribute - file not found} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot readonlyAttr} -returnCodes error -body {
file attributes foo.test -readonly
|
| ︙ | ︙ |
Changes to tests/unixFile.test.
1 2 3 4 5 6 | # This file contains tests for the routines in the file tclUnixFile.c # # 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 |
# This file contains tests for the routines in the file tclUnixFile.c
#
# 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 © 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.
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 testfindexecutable [llength [info commands testfindexecutable]]
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
file attributes [makeFile "" junk] -perm 0o777
}
set absPath [file join [temporaryDirectory] junk]
test unixFile-1.1 {Tcl_FindExecutable} {testfindexecutable unix} {
set env(PATH) ""
testfindexecutable junk
} $absPath
|
| ︙ | ︙ |
Changes to tests/unixForkEvent.test.
1 2 3 4 | # This file contains a collection of tests for the procedures in the file # tclUnixNotify.c. 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 |
# This file contains a collection of tests for the procedures in the file
# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1995-1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint testfork [llength [info commands testfork]]
# Test if the notifier thread is well initialized in a forked interpreter
# by Tcl_InitNotifier
test unixforkevent-1.1 {fork and test writeable event} \
-constraints {testfork nonPortable} \
|
| ︙ | ︙ |
Changes to tests/unixInit.test.
1 2 3 4 5 6 | # The file tests the functions in the tclUnixInit.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 |
# The file tests the functions in the tclUnixInit.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.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
# Some tests require the testgetencpath command
testConstraint testgetencpath [llength [info commands testgetencpath]]
|
| ︙ | ︙ |
Changes to tests/unixNotfy.test.
1 2 3 4 5 6 | # This file contains tests for tclUnixNotfy.c. # # 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 |
# This file contains tests for tclUnixNotfy.c.
#
# 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 © 1997 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
| ︙ | ︙ |
Changes to tests/unknown.test.
1 2 3 4 5 6 | # Commands covered: unknown # # 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 |
# Commands covered: unknown
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain x
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
list [catch {_non-existent_ foo bar} msg] $msg
} {1 {invalid command name "_non-existent_"}}
|
| ︙ | ︙ |
Changes to tests/unload.test.
1 2 3 4 5 6 | # Commands covered: unload # # 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 41 42 43 44 45 46 47 |
# Commands covered: unload
#
# 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 © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2003-2004 Georgios Petasis
#
# 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]]
# Figure out what extension is used for shared libraries on this
# platform.
if {![info exists ext]} {
set ext [info sharedlibextension]
}
# Tests require the existence of one of the DLLs in the dltest directory.
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkgua$ext]
set dll "[file tail $x]Required"
testConstraint $dll [file readable $x]
# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}]
set alreadyTotalLoaded [info loaded]
# Certain tests need the 'testsimplefilsystem' in tcltest
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
proc loadIfNotPresent {pkg args} {
global testDir ext
set loaded [lmap x [info loaded {*}$args] {lindex $x 1}]
|
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
unload -nocomplain {} Unknown
} {}
set pkgua_loaded {}
set pkgua_detached {}
set pkgua_unloaded {}
# Tests for loading/unloading in trusted (non-safe) interpreters...
| | | | | | | | | | | | | | | | | | | | 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 |
unload -nocomplain {} Unknown
} {}
set pkgua_loaded {}
set pkgua_detached {}
set pkgua_unloaded {}
# Tests for loading/unloading in trusted (non-safe) interpreters...
test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] {
loadIfNotPresent pkga
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}}
test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup {
loadIfNotPresent pkga
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkga$ext]
} -result {file "*" cannot be unloaded under a trusted interpreter}
test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup {
loadIfNotPresent pkgua
} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} -result {. {} {} {} {} . . .}
test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup {
if {$pkgua_loaded eq ""} {
loadIfNotPresent pkgua
unload [file join $testDir pkgua$ext]
}
} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -setup {
# Establish expected state
if {$pkgua_loaded eq ""} {
loadIfNotPresent pkgua
unload [file join $testDir pkgua$ext]
load [file join $testDir pkgua$ext]
}
} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} -result {.. . . {} {} .. .. ..}
# Tests for loading/unloading in safe interpreters...
interp create -safe child
child eval {
set pkgua_loaded {}
set pkgua_detached {}
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 pkgb$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 pkgua$ext] pkgua child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup {
loadIfNotPresent pkga
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkga$ext] {} child
} -result {file "*" has never been loaded in this interpreter}
test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup {
if {[lsearch -index 1 [info loaded child] Pkgb] < 0} {
load [file join $testDir pkgb$ext] Pkgb child
}
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkgb$ext] {} child
} -result {file "*" cannot be unloaded under a safe interpreter}
test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup {
if {[lsearch -index 1 [info loaded child] Pkgua] < 0} {
load [file join $testDir pkgua$ext] Pkgua child
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. {} {}} {} {} {. . .}}
test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup {
if {[child eval set pkgua_loaded] eq ""} {
load [file join $testDir pkgua$ext] {} child
unload [file join $testDir pkgua$ext] {} child
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] {} child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup {
if {[child eval set pkgua_loaded] eq ""} {
load [file join $testDir pkgua$ext] {} child
unload [file join $testDir pkgua$ext] {} child
load [file join $testDir pkgua$ext] {} child
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
|
| ︙ | ︙ | |||
202 203 204 205 206 207 208 |
child-trusted eval {
set pkgua_loaded {}
set pkgua_detached {}
set pkgua_unloaded {}
}
array set load {M 0 C 0 T 0}
## Load package in main trusted interpreter...
| | | | | | | | | | 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 |
child-trusted eval {
set pkgua_loaded {}
set pkgua_detached {}
set pkgua_unloaded {}
}
array set load {M 0 C 0 T 0}
## Load package in main trusted interpreter...
test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for prefix} -setup {
set pkgua_loaded ""
set pkgua_detached ""
set pkgua_unloaded ""
incr load(M)
} -constraints [list $dll $loaded] -body {
list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-safe interpreter...
test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup {
child eval {
set pkgua_loaded ""
set pkgua_detached ""
set pkgua_unloaded ""
}
incr load(C)
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] pkgua child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-trusted interpreter...
test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup {
incr load(T)
} -constraints [list $dll $loaded] -body {
list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] pkgua child-trusted] \
[child-trusted eval pkgua_eq abc def] \
[lsort [child-trusted eval info commands pkgua_*]] \
[child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Unload the package from the main trusted interpreter...
test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup {
if {!$load(M)} {
load [file join $testDir pkgua$ext]
}
if {!$load(C)} {
load [file join $testDir pkgua$ext] {} child
incr load(C)
}
if {!$load(T)} {
load [file join $testDir pkgua$ext] {} child-trusted
incr load(T)
}
} -constraints [list $dll $loaded] -body {
list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child safe interpreter...
test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
if {!$load(C)} {
load [file join $testDir pkgua$ext] {} child
}
if {!$load(T)} {
load [file join $testDir pkgua$ext] {} child-trusted
incr load(T)
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child trusted interpreter...
test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
if {!$load(T)} {
load [file join $testDir pkgua$ext] {} child-trusted
}
} -constraints [list $dll $loaded] -body {
list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child-trusted] \
[child-trusted eval info commands pkgua_*] \
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
1 2 3 4 5 6 | # Commands covered: uplevel # # 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 |
# Commands covered: uplevel
#
# 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 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
proc a {x y} {
newset z [expr {$x + $y}]
return $z
}
proc newset {name value} {
uplevel set $name $value
uplevel 1 {uplevel 1 {set xyz 22}}
}
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 |
}
foo
moo
} -cleanup {
rename foo {}
rename moo {}
} -result {3 3 3}
| | > > > > > > > > > > > > > > > > > | 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 |
}
foo
moo
} -cleanup {
rename foo {}
rename moo {}
} -result {3 3 3}
test uplevel-8.0 {
string representation isn't generated when there is only one argument
} -body {
set res {}
set script [list lindex 5]
lappend res [apply {script {
uplevel $script
}} $script]
lappend res [string match {value is a list *no string representation*} [
::tcl::unsupported::representation $script]]
} -cleanup {
unset script
unset res
} -result {5 1}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
Changes to tests/upvar.test.
1 2 3 4 5 6 | # Commands covered: 'upvar', 'namespace upvar' # # 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 |
# Commands covered: 'upvar', 'namespace upvar'
#
# 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 Sun Microsystems, Inc.
# 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.
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 testupvar [llength [info commands testupvar]]
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
|
| ︙ | ︙ |
Changes to tests/utf.test.
1 2 3 4 | # This file contains a collection of tests for tclUtf.c # 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 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 |
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}]
testConstraint ucs4 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}]
testConstraint Uesc [expr {"\U0041" eq "A"}]
testConstraint pre388 [expr {"\x741" eq "A"}]
testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]]
&& [string length [teststringbytes \uD83D\uDCA9]] == 4}]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testfindfirst [llength [info commands testfindfirst]]
testConstraint testfindlast [llength [info commands testfindlast]]
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
testConstraint teststringobj [llength [info commands teststringobj]]
testConstraint testutfnext [llength [info commands testutfnext]]
testConstraint testutfprev [llength [info commands testutfprev]]
testConstraint tip413 [expr {[string trim \x00] eq {}}]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
expr {"\x01" eq [testbytestring \x01]}
} 1
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\x00" eq [testbytestring \xC0\x80]}
} 1
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\xE0" eq [testbytestring \xC3\xA0]}
} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]}
} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 1
test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 0
test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {"\uD842" eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {"\uDC42" eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} {
expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} 3
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
string length [testbytestring \x82\x83\x84]
} 3
test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring {
string length [testbytestring \xC2]
} 1
test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
string length \xA2
} 1
test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring {
string length [testbytestring \xE2]
} 1
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
string length [testbytestring \xE2\xA2]
} 2
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring \xE4\xB9\x8E]
} 1
test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} {
string length [testbytestring \xF0\x90\x80\x80]
} 2
test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} {
string length [testbytestring \xF0\x90\x80\x80]
} 1
test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} {
string length [testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} {
string length \U10FFFF
} 1
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring \xF0\x8F\xBF\xBF]
} 4
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
# Would decode to U+110000 but that is outside the Unicode range.
string length [testbytestring \xF4\x90\x80\x80]
} 4
test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
string length [testbytestring \xF8\xA2\xA2\xA2\xA2]
} 5
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} 0
test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
testnumutfchars \xA2
} 1
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E]
} 7
test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars {
testnumutfchars \x00
} 1
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 0
} 0
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
testnumutfchars \xA2 end
} 1
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end
} 7
test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars {
testnumutfchars \x00 end
} 1
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xE2\x82\xAC] end-1
} 2
test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \x00] end+1
} 2
test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1
} 3
test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 2
test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 1
test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} {
testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end
} 8
test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1
} 3
test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} {
testfindfirst [testbytestring abcbc] 98
} bcbc
test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} {
testfindlast [testbytestring abcbc] 98
} bc
test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} {
# This takes the pointer one past the terminating NUL.
# This is really an invalid call.
testutfnext [testbytestring \x00]
} 1
test utf-6.2 {Tcl_UtfNext} testutfnext {
testutfnext A
} 1
test utf-6.3 {Tcl_UtfNext} testutfnext {
testutfnext AA
} 1
test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xA0]
} 1
test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xD0]
} 1
test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xE8]
} 1
test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF2]
} 1
test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF8]
} 1
test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\x00]
} 1
test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0]G
} 1
test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xD0]
} 1
test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xE8]
} 1
test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF2]
} 1
test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF8]
} 1
test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\x00]
} 1
test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0]G
} 1
test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]
} 2
test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xD0]
} 1
test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xE8]
} 1
test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF2]
} 1
test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF8]
} 1
test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\x00]
} 1
test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8]G
} 1
test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\x00]
} 1
test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xD0]
} 1
test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xE8]
} 1
test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF2]
} 1
test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF8]
} 1
test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2]
} 1
test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\x00]
} 1
test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2]G
} 1
test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0]
} 1
test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\x00]
} 1
test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xD0]
} 1
test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xE8]
} 1
test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF2]
} 1
test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF8]
} 1
test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]
} 1
test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]G
} 1
test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xA0]
} 1
test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xD0]
} 1
test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xE8]
} 1
test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF2]
} 1
test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF8]
} 1
test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]G
} 2
test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xA0]
} 2
test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xD0]
} 2
test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xE8]
} 2
test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF2]
} 2
test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF8]
} 2
test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0]G
} 1
test utf-6.51 {Tcl_UtfNext} testutfnext {
testutfnext \u8820
} 3
test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xD0]
} 1
test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xE8]
} 1
test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF2]
} 1
test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF8]
} 1
test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0]G
} 1
test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\x00]
} 1
test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xD0]
} 1
test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xE8]
} 1
test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF2]
} 1
test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF8]
} 1
test utf-6.62 {Tcl_UtfNext} testutfnext {
testutfnext \u8820G
} 3
test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xA0]
} 3
test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xD0]
} 3
test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xE8]
} 3
test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF2]
} 3
test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF8]
} 3
test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0]G
} 1
test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 1
test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 4
test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xD0]
} 1
test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xE8]
} 1
test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF2]
} 1
test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF8]
} 1
test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 1
test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 4
test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 1
test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 4
test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 1
test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 4
test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 1
test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 4
test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 1
test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 4
test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 1
test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 4
test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext {
testutfnext \x00
} 2
test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC0\x81]
} 1
test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC1\x80]
} 1
test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC2\x80]
} 2
test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\x80\x80]
} 1
test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\xA0\x80]
} 3
test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x80\x80\x80]
} 1
test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 1
test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 4
test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x00]
} 2
test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 1
test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 4
test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
testutfnext [testbytestring \xF4\x90\x80\x80]
} 1
test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0]
} 3
test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80]
} 3
test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0\xA0]
} 3
test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80\x80]
} 3
test utf-7.1 {Tcl_UtfPrev} testutfprev {
testutfprev {}
} 0
test utf-7.2 {Tcl_UtfPrev} testutfprev {
testutfprev A
} 0
test utf-7.3 {Tcl_UtfPrev} testutfprev {
testutfprev AA
} 1
test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8]
} 1
test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2
} 1
test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2
} 1
test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2]
} 1
test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2
} 1
test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2
} 1
test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8]
} 1
test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 2
} 1
test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2
} 1
test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0]
} 1
test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2
} 1
test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2
} 1
test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0]
} 1
test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2
} 1
test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2
} 1
test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0]
} 2
test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3
} 2
test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3
} 2
test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0]
} 2
test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0]
} 1
test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 2
test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 1
test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 2
test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 1
test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0]
} 1
test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 3
} 1
test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3
} 1
test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8] 3
} 1
test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0]
} 1
test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3
} 1
test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3
} 1
test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0]
} 2
test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3
} 2
test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3
} 2
test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0]
} 3
test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4
} 3
test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4
} 3
test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 3
test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 1
test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 3
test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 1
test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 3
test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 1
test utf-7.16 {Tcl_UtfPrev} testutfprev {
testutfprev A\u8820
} 1
test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 4
} 1
test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xF8] 4
} 1
test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0]
} 3
test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4
} 3
test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4
} 3
test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0]
} 1
test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4
} 1
test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4
} 1
test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0]
} 2
test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0]
} 2
test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A\u8820[testbytestring \xA0]
} 2
test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0]
} 2
test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0]
} 2
test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81]
} 2
test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81] 2
} 1
test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80]
} 3
test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80]
} 2
test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 3
} 2
test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0]
} 1
test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 2
} 1
test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x80\x80\x80]
} 2
test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 4
} 3
test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 3
} 2
test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 2
} 1
test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev {
testutfprev A\x00
} 1
test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC1\x80]
} 2
test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC2\x80]
} 1
test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80]
} 1
test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 3
} 1
test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 2
} 1
test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x90\x80\x80]
} 2
test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 3
test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 1
test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 2
test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 1
test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 2
} 1
test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0]
} 0
test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0]
} 1
test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0\xA0]
} 2
test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} {
testutfprev [testbytestring \xA0\xA0\xA0\xA0]
} 1
test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0]
} 0
test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev {
testutfprev \u8820 2
} 0
test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0\x00] 2
} 0
test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 3
test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 1
test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 2
test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 1
test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2
} 1
test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x90\x80\x80]
} 2
test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 4
} 3
test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 3
} 2
test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 2
} 1
test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} a
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
string index \u4E4E\u25A 0
} \u4E4E
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} c
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4E4E\u25A\xFF\u543 2
} \xFF
test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
string index \uD842 0
} \uD842
test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 {
string index \uD842 0
} \uD842
test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 {
string index \uD842 0
} \uD842
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \uDC42 0
} \uDC42
test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 0
} \uD83D
test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 1
} \uDE00
test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 1
} G
test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 1
} {}
test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 2
} G
test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 2
} {}
test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 2
} G
test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 0
} \uFFFD
test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 0
} \U1F600
test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 0
} \U1F600
test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 1
} G
test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 1
} G
test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 1
} {}
test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 2
} {}
test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 2
} {}
test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 2
} G
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} abc
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4E4E\u25A\xFF\u543klmnop 1 5
} \u25A\xFF\u543kl
test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 {
string range \uD83D\uDE00G 0 0
} \uD83D
test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 1 1
} \uDE00
test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \uD83D\uDE00G 1 1
} G
test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 1 1
} {}
test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \uD83D\uDE00G 2 2
} {}
test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} {
string range \U1f600G 0 0
} \uFFFD
test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} {
string range \U1f600G 0 0
} \U1F600
test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} {
string range \U1f600G 0 0
} \U1F600
test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 1 1
} G
test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 1 1
} G
test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 1 1
} {}
test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 2 2
} {}
test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 2 2
} {}
test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 2 2
} G
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
expr {"\uA2" eq [testbytestring \xC2\xA2]}
} 1
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]}
} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"}
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} {
expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"}
} 1
test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} {
expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"}
} 1
proc bsCheck {char num {constraints {}}} {
global errNum
test utf-10.$errNum {backslash substitution} $constraints {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 8
bsCheck \b 8
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | bsCheck \14 12 bsCheck \141 97 bsCheck b\0 98 bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 | > | | > | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | > > > > > > | | > > > > > > | 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 |
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98
bsCheck \x 120
bsCheck \xa 10
bsCheck \xA 10
bsCheck \x41 65
bsCheck \x541 65 pre388 ;# == \x41
bsCheck \x541 84 !pre388 ;# == \x54 1
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
bsCheck \ua 10
bsCheck \uA 10
bsCheck \340 224
bsCheck \uA1 161
bsCheck \u4E21 20001
bsCheck \741 225 pre388 ;# == \341
bsCheck \741 60 !pre388 ;# == \74 1
bsCheck \U 85
bsCheck \Uk 85
bsCheck \U41 65 Uesc
bsCheck \Ua 10 Uesc
bsCheck \UA 10 Uesc
bsCheck \UA1 161 Uesc
bsCheck \U4E21 20001 Uesc
bsCheck \U004E21 20001 Uesc
bsCheck \U00004E21 20001 Uesc
bsCheck \U0000004E21 78 Uesc
bsCheck \U00110000 69632 {Uesc fullutf}
bsCheck \U01100000 69632 {Uesc fullutf}
bsCheck \U11000000 69632 {Uesc fullutf}
bsCheck \U0010FFFF 1114111 {Uesc fullutf}
bsCheck \U010FFFF0 1114111 {Uesc fullutf}
bsCheck \U10FFFF00 1114111 {Uesc fullutf}
bsCheck \UFFFFFFFF 1048575 {Uesc fullutf}
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \xE3gh
} \xC3GH
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01E3gh
} \u01E2GH
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
string toupper \u10D0\u1C90
} \u1C90\u1C90
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} {
string toupper \U10428
} \U10400
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper \uD801\uDC28
} \uD801\uDC00
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \uDC24\uD824
} \uDC24\uD824
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \xC3GH
} \xE3gh
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01E2GH
} \u01E3gh
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
string tolower \u10D0\u1C90
} \u10D0\u10D0
test utf-12.6 {Tcl_UtfToLower low/high surrogate)} {
string tolower \uDC24\uD824
} \uDC24\uD824
test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} {
string tolower \U10400
} \U10428
test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
string tolower \uD801\uDC00
} \uD801\uDC28
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
string totitle \xE3GH
} \xC3gh
test utf-13.4 {Tcl_UtfToTitle} {
string totitle \u01F3AB
} \u01F2ab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u10D0\u1C90
} \u10D0\u1C90
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u1C90\u10D0
} \u1C90\u10D0
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} {
string totitle \uDC24\uD824
} \uDC24\uD824
test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} {
string totitle \U10428\U10400
} \U10400\U10428
test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
string totitle \uD801\uDC28\uD801\uDC00
} \uD801\uDC00\uD801\uDC28
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
| | | | 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 |
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
string tolower \u0178\xFF\uA78D\u01C5
} \xFF\xFF\u0265\u01C6
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
test utf-18.1 {Tcl_UniCharToTitle, add one for title} {
string totitle \u01C4
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
} -cleanup {
unset -nocomplain foo
} -result {1 4}
| | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > > > > > > > > | | | | | < < < | < < < < < < < < < < < < | | | | < | | | > > > | < | > | | | | | | | | > | | > | < < | < < | < | | | | | < | | | | | | 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 |
test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
} -cleanup {
unset -nocomplain foo
} -result {1 4}
test utf-20.1 {TclUniCharNcmp} ucs4 {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs2 {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
string range $one 0 0
string range $two 0 0
set second [string compare $one $two]
expr {($first == $second) ? "agree" : "disagree"}
} agree
test utf-20.2.1 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {utf16 knownBug} {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
string range $one 0 0
string range $two 0 0
set second [string compare $one $two]
expr {($first == $second) ? "agree" : "disagree"}
} agree
test utf-20.2.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
string range $one 0 0
string range $two 0 0
set second [string compare $one $two]
expr {($first == $second) ? "agree" : "disagree"}
} agree
test utf-21.1 {TclUniCharIsAlnum} {
# this returns 1 with Unicode 7 compliance
string is alnum \u1040\u021F\u0220
} 1
test utf-21.2 {unicode alnum char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:print:]]+$} \uFBC1
} 1
test utf-21.4 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \u0120
} 1
test utf-21.5 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {^[[:graph:]]+$} \u0120
} 1
test utf-21.6 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \xA0
} 0
test utf-21.7 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:graph:]]} \x20\xA0\u2028\u2029
} 0
test utf-21.8 {TclUniCharIsPrint} {
# [Bug 3464428]
string is print \x09
} 0
test utf-21.9 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.10 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
string is control \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428], [Bug a876646efe]
regexp {^[[:cntrl:]]*$} \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
} 10
test utf-22.2 {TclUniCharIsWordChar} {
string wordend "x\u5080z123_bar\u203C fg" 0
} 10
test utf-23.1 {TclUniCharIsAlpha} {
# this returns 1 with Unicode 7 compliance
string is alpha \u021F\u0220\u037F\u052F
} 1
test utf-23.2 {unicode alpha char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F
} 1
test utf-24.1 {TclUniCharIsDigit} {
# this returns 1 with Unicode 7 compliance
string is digit \u1040\uABF0
} 1
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
# this returns 1 with Unicode 7 compliance
string is space \u1680\u180E\u202F
} 1
test utf-24.4 {unicode space char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:space:]]+$} \u1680\u180E\u202F] [regexp {^\s+$} \u1680\u180E\u202F]
} {1 1}
test utf-24.5 {TclUniCharIsSpace} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
string is space \x85\u1680\u180E\u200B\u202F\u2060
} 1
test utf-24.6 {unicode space char in regc_locale.c} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060]
} {1 1}
proc UniCharCaseCmpTest {order one two {constraints {}}} {
variable count
test utf-25.$count {Tcl_UniCharNcasecmp} -setup {
testobj freeallvars
} -constraints [linsert $constraints 0 teststringobj] -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 $one
teststringobj set 2 $two
teststringobj maxchars 1
teststringobj maxchars 2
set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]]
if {$result eq [string map {< -1 = 0 > 1} $order]} {
set result ok
} else {
set result "'$one' should be $order '$two' (no case)"
}
set result
} -result ok
incr count
}
variable count 1
UniCharCaseCmpTest < a b
UniCharCaseCmpTest > b a
UniCharCaseCmpTest > B a
UniCharCaseCmpTest > aBcB abca
UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4
UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4}
UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4
UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4}
test utf-26.1 {Tcl_UniCharDString} -setup {
testobj freeallvars
} -constraints {teststringobj testbytestring} -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 foo
teststringobj maxchars 1
teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10
scan [string index [teststringobj get 1] 11] %c
} -result 128
unset count
rename UniCharCaseCmpTest {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/util.test.
1 2 3 | # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1995-1998 Sun Microsystems, Inc.
# 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.
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 controversialNaN 1
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
testConstraint testprint [llength [info commands testprint]]
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
concat x[expr 1.4]
} -cleanup {
| > > > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-5.52 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch \[a\u0000 a\x80
} 0
test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
concat x[expr 1.4]
} -cleanup {
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
set tcl_precision 12
list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} -cleanup {
set ::tcl_precision $old_precision
} -result {1 {can't set "tcl_precision": improper value for precision} 12}
# This test always succeeded in the C locale anyway...
| | | | | | < < < < < | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
set tcl_precision 12
list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} -cleanup {
set ::tcl_precision $old_precision
} -result {1 {can't set "tcl_precision": improper value for precision} 12}
# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct utf-8 handling} {
# Bug 411825
# Note that this test relies on the fact that
# [interp target] calls on Tcl_AppendElement()
# which calls on TclNeedSpace(). If [interp target]
# is ever updated, this test will no longer test
# TclNeedSpace.
interp create \u5420
interp create [list \u5420 foo]
interp alias {} fooset [list \u5420 foo] set
set result [interp target {} fooset]
interp delete \u5420
set result
} "\u5420 foo"
test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring {
# Bug 411825
# This tests the same bug as the previous test, but
# should be more future-proof, as the DString
# operations will likely continue to call TclNeedSpace
testdstring free
testdstring append \u5420 -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring {
# Bug 411825 - new variant reported by Dossy Shiobara
testdstring free
testdstring append \u00A0 -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring {
# Another bug uncovered while fixing 411825
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring {
testdstring free
testdstring append {\\ } -1
testdstring element foo
list [llength [testdstring get]] [string length [testdstring get]]
} {2 6}
test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring {
testdstring free
testdstring append {\\ } -1
testdstring append \{ -1
testdstring element foo
testdstring append \} -1
list [llength [testdstring get]] [string length [testdstring get]]
} {2 8}
test util-8.7 {TclNeedSpace - watch out for escaped space} testdstring {
testdstring free
testdstring append {\ } -1
testdstring start
testdstring end
# Should make {\ {}}
list [llength [testdstring get]] [string index [testdstring get] 3]
} {2 \{}
test util-8.8 {TclNeedSpace - watch out for escaped space} testdstring {
testdstring free
testdstring append {\\ } -1
testdstring start
testdstring end
# Should make {\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 3]
} {2 \{}
test util-8.9 {TclNeedSpace - watch out for escaped space} testdstring {
testdstring free
testdstring append {\\\ } -1
testdstring start
testdstring end
# Should make {\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 5]
} {2 \{}
test util-8.10 {TclNeedSpace - watch out for escaped space} testdstring {
testdstring free
testdstring append {\\\\\\\ } -1
testdstring start
testdstring end
# Should make {\\\\\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring {
testdstring free
testdstring append {\\\\\\\\ } -1
testdstring start
testdstring end
# Should make {\\\\\\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
test util-9.0.0 {Tcl_GetIntForIndex} {
string index abcd 0
} a
test util-9.0.1 {Tcl_GetIntForIndex} {
string index abcd 0x0
} a
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
} -returnCodes error -match glob -result *
test util-9.43 {Tcl_GetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {Tcl_GetIntForIndex} -body {
string index a 0+1000000000000
} -result {}
| | | | | | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 |
} -returnCodes error -match glob -result *
test util-9.43 {Tcl_GetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {Tcl_GetIntForIndex} -body {
string index a 0+1000000000000
} -result {}
test util-9.45 {Tcl_GetIntForIndex} -body {
string index abcd end+2305843009213693950
} -result {}
test util-9.46 {Tcl_GetIntForIndex} -body {
string index abcd end+4294967294
} -result {}
# TIP 502
test util-9.47 {Tcl_GetIntForIndex} -body {
string index abcd 0x10000000000000000
} -result {}
test util-9.48 {Tcl_GetIntForIndex} {
string index abcd -0x10000000000000000
} {}
test util-9.49 {Tcl_GetIntForIndex} -body {
string index abcd end*1
} -returnCodes error -match glob -result *
test util-9.50 {Tcl_GetIntForIndex} -body {
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
} -returnCodes error -match glob -result *
test util-9.53 {Tcl_GetIntForIndex} -body {
string index abcd end-0.1
} -returnCodes error -match glob -result *
test util-9.54 {Tcl_GetIntForIndex} {
string index abcd end-0x10000000000000000
} {}
| | | | | | > > > | 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 |
} -returnCodes error -match glob -result *
test util-9.53 {Tcl_GetIntForIndex} -body {
string index abcd end-0.1
} -returnCodes error -match glob -result *
test util-9.54 {Tcl_GetIntForIndex} {
string index abcd end-0x10000000000000000
} {}
test util-9.55 {Tcl_GetIntForIndex} -body {
string index abcd end+0x10000000000000000
} -result {}
test util-9.56 {Tcl_GetIntForIndex} -body {
string index abcd end--0x10000000000000000
} -result {}
test util-9.57 {Tcl_GetIntForIndex} {
string index abcd end+-0x10000000000000000
} {}
test util-9.58 {Tcl_GetIntForIndex} -body {
string index abcd end--0x8000000000000000
} -result {}
test util-9.59 {Tcl_GetIntForIndex} {
string index abcd 0-0x10000000000000000
} {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
|
| ︙ | ︙ |
Changes to tests/var.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the tclVar.c source file. Tests appear in the # same order as the C code that they test. The set of tests is currently # incomplete since it currently includes only new tests for code changed for # the addition of Tcl namespaces. Other variable-related tests appear in # several other test files including namespace.test, set.test, trace.test, and # upvar.test. # # 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 |
# This file contains tests for the tclVar.c source file. Tests appear in the
# same order as the C code that they test. The set of tests is currently
# incomplete since it currently includes only new tests for code changed for
# the addition of Tcl namespaces. Other variable-related tests appear in
# several other test files including namespace.test, set.test, trace.test, and
# upvar.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 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 {} {
|
| ︙ | ︙ | |||
448 449 450 451 452 453 454 |
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::*]] \
| | | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 |
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 ""
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
proc doit {} {
| | | | | 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 |
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
rename doit {}
} -result 0
test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
proc doit {} {
interp create child
child eval {
proc doit script {
eval $script
set foo bar
}
doit {foreach foo baz {}}
}
interp delete child
}
} -constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
doit
set tmp $end
set end [getbytes]
|
| ︙ | ︙ |
Changes to tests/while-old.test.
1 2 3 4 5 6 7 8 | # Commands covered: while # # This file contains the original set of tests for Tcl's while command. # Since the while command is now compiled, a new set of tests covering # the new implementation is in the file "while.test". 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 |
# Commands covered: while
#
# This file contains the original set of tests for Tcl's while command.
# Since the while command is now compiled, a new set of tests covering
# the new implementation is in the file "while.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# 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::*
}
test while-old-1.1 {basic while loops} {
set count 0
while {$count < 10} {set count [expr {$count + 1}]}
set count
} 10
test while-old-1.2 {basic while loops} {
set value xxx
while {2 > 3} {set value yyy}
set value
} xxx
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
} {2}
test while-old-2.1 {continue in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
| | | | | 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 |
} {2}
test while-old-2.1 {continue in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 2} {set index [expr {$index + 1}]; continue}
set result [concat $result [lindex $list $index]]
set index [expr {$index + 1}]
}
set result
} {1 2 4 5}
test while-old-3.1 {break in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 3} break
set result [concat $result [lindex $list $index]]
set index [expr {$index + 1}]
}
set result
} {1 2 3}
test while-old-4.1 {errors in while loops} {
set err [catch {while} msg]
list $err $msg
|
| ︙ | ︙ |
Changes to tests/while.test.
1 2 3 4 5 6 | # Commands covered: while # # 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 |
# Commands covered: while
#
# 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 © 1996 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Basic "while" operation.
catch {unset i}
catch {unset a}
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
} -result {wrong # args: should be "set varName ?newValue?"
while *ing
"set"*}
test while-1.9 {TclCompileWhileCmd: simple command body} -body {
set a {}
set i 1
while {$i<6} {
| | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
} -result {wrong # args: should be "set varName ?newValue?"
while *ing
"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}
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
} -cleanup {
unset x1 bb x2 a i
} -result {x1}
test while-1.12 {TclCompileWhileCmd: long command body} -body {
set a {}
set i 1
while {$i<6} {
| | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
} -cleanup {
unset x1 bb x2 a i
} -result {x1}
test while-1.12 {TclCompileWhileCmd: long command body} -body {
set a {}
set i 1
while {$i<6} {
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
set a [while {$i < 5} {incr i}]
return $a
} -cleanup {
unset a i
} -result {}
test while-1.14 {TclCompileWhileCmd: while command result} -body {
set i 0
| | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
set a [while {$i < 5} {incr i}]
return $a
} -cleanup {
unset a i
} -result {}
test while-1.14 {TclCompileWhileCmd: while command result} -body {
set i 0
set a [while {$i < 5} {if {$i==3} break; incr i}]
return $a
} -cleanup {
unset a i
} -result {}
# Check "while" and "continue".
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
} -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 {}
set i 1
while {$i<6} {
| | | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
} -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 {}
set i 1
while {$i<6} {
if {$i==2} {incr i; continue}
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
} -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 {}
set i 1
while {$i<6} {
| | | | | | 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 |
} -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 {}
set i 1
while {$i<6} {
if {$i==2} {incr i; continue}
if {$i==5} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i==4} break
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
invoked from within
"$z {$i < 5} {set}"}
test while-4.10 {while (not compiled): simple command body} -body {
set a {}
set i 1
set z while
$z {$i<6} {
| | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
invoked from within
"$z {$i < 5} {set}"}
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}
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 |
unset z x1 bb x2 a i
} -result {x1}
test while-4.13 {while (not compiled): long command body} -body {
set a {}
set z while
set i 1
$z {$i<6} {
| | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
unset z x1 bb x2 a i
} -result {x1}
test while-4.13 {while (not compiled): long command body} -body {
set a {}
set z while
set i 1
$z {$i<6} {
if {$i==4} break
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 |
return $a
} -cleanup {
unset a i z
} -result {}
test while-4.15 {while (not compiled): while command result} -body {
set i 0
set z while
| | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
return $a
} -cleanup {
unset a i z
} -result {}
test while-4.15 {while (not compiled): while command result} -body {
set i 0
set z while
set a [$z {$i < 5} {if {$i==3} break; incr i}]
return $a
} -cleanup {
unset a i z
} -result {}
# Check "break" with computed command names.
|
| ︙ | ︙ | |||
534 535 536 537 538 539 540 |
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 {}
set i 1
set z break
while {$i<6} {
| | | | | | 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 |
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 {}
set i 1
set z break
while {$i<6} {
if {$i==2} {incr i; continue}
if {$i==5} $z
if {$i>5} continue
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i==4} $z
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
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 {}
set i 1
set z continue
while {$i<6} {
| | | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
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 {}
set i 1
set z continue
while {$i<6} {
if {$i==2} {incr i; continue}
if {$i==4} break
if {$i>5} $z
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
catch {incr i 5} msg
catch {incr i -5} msg
}
if {$i>6 && $tcl_platform(machine)=="xxx"} {
catch {set a $a} msg
|
| ︙ | ︙ |
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 |
# 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.
#
# Copyright © 1999 Scriptics Corporation.
#
# 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::*
}
test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} {
set oldmode [fconfigure stdin]
|
| ︙ | ︙ |
Changes to tests/winDde.test.
1 2 3 4 5 6 | # This file tests the tclWinDde.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 41 42 43 44 45 46 47 48 49 50 51 52 53 |
# This file tests the tclWinDde.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.
#
# Copyright © 1999 Scriptics Corporation.
#
# 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::*
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
set ::ddever [package require dde 1.4.3]
set ::ddelib [info loaded {} Dde]}]} {
testConstraint dde 1
}
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# -------------------------------------------------------------------------
# Setup a script for a test server
#
set scriptName [makeFile {} script1.tcl]
proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
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
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
} {1.4.3}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
| | | | | 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 |
} {1.4.3}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}
test winDde-2.1 {Checking for other services} -constraints dde -body {
expr {[llength [dde services {} {}]] >= 0}
} -result 1
test winDde-2.2 {Checking for existence, with service and topic specified} \
-constraints dde -body {
llength [dde services TclEval self]
} -result 1
test winDde-2.3 {Checking for existence, with only the service specified} \
-constraints dde -body {
expr {[llength [dde services TclEval {}]] >= 1}
} -result 1
test winDde-2.4 {Checking for existence, with only the topic specified} \
-constraints dde -body {
expr {[llength [dde services {} self]] >= 1}
} -result 1
# -------------------------------------------------------------------------
test winDde-3.1 {DDE execute locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
| | | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
set \xe1 ""
dde execute TclEval self [list set \xe1 foo]
dde request -binary TclEval self \xe1
} -result "foo\x00"
# Set variable a to A with diaeresis (unicode C4) by relying on the fact
# that utf-8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf-8} -constraints dde -body {
set \xe1 "not set"
dde execute TclEval self "set \xe1 \xc4"
scan [set \xe1] %c
} -result 196
# Set variable a to A with diaeresis (unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manualy
test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body {
set \xe1 "not set"
dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
scan [set \xe1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
set \xe1 ""
dde poke TclEval self \xe1 \xc4
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
} -cleanup {
dde execute TclEval $name {set done 1}
update
} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
} -cleanup {
dde execute TclEval $name {set done 1}
update
} -result "ch\xEDld-6.6"
# -------------------------------------------------------------------------
test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup {
interp create child
} -body {
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.1]
} -cleanup {
interp delete child
} -result {dde-interp-7.1}
test winDde-7.2 {DDE child cleanup} -constraints dde -setup {
interp create child
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.5]
interp delete child
} -body {
dde services TclEval {}
set s [dde services TclEval {}]
set m [list [list TclEval dde-interp-7.5]]
if {$m in $s} {
set s
}
} -result {}
test winDde-7.3 {DDE present in child interp} -constraints dde -setup {
interp create child
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.3]
} -body {
dde services TclEval dde-interp-7.3
} -cleanup {
interp delete child
} -result {{TclEval dde-interp-7.3}}
test winDde-7.4 {interp name collision with -force} -constraints dde -setup {
interp create child
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.4]
} -body {
dde servername -force -- dde-interp-7.4
} -cleanup {
interp delete child
} -result {dde-interp-7.4}
test winDde-7.5 {interp name collision without -force} -constraints dde -setup {
interp create child
child eval [list load $::ddelib Dde]
child eval [list dde servername -- dde-interp-7.5]
} -body {
dde servername -- dde-interp-7.5
} -cleanup {
interp delete child
} -result "dde-interp-7.5 #2"
# -------------------------------------------------------------------------
test winDde-8.1 {Safe DDE load} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
} -body {
child eval dde servername child
} -cleanup {
interp delete child
} -returnCodes error -result {invalid command name "dde"}
test winDde-8.2 {Safe DDE set servername} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
} -body {
child invokehidden dde servername child
} -cleanup {interp delete child} -result {child}
test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
catch {dde eval child set a 1} msg
} -cleanup {interp delete child} -result {1}
test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
child eval set a 1
dde execute TclEval child {set a 2}
child eval set a
} -cleanup {interp delete child} -result 1
test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child invokehidden dde servername child
} -body {
child eval set a 1
dde request TclEval child a
} -cleanup {
interp delete child
} -returnCodes error -result {remote server cannot handle this command}
test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
} -body {
child invokehidden dde servername -handler DDEACCEPT child
} -cleanup {interp delete child} -result child
test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
dde eval child set x 1
} -cleanup {interp delete child} -result {set x 1}
test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
set s "c:\\Program Files\\Microsoft Visual Studio\\"
dde eval child $s
string equal [child eval set DDECMD] $s
} -cleanup {interp delete child} -result 1
test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
dde eval child set \xe1 1
child eval set \xe1
} -cleanup {interp delete child} -result 1
test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
dde eval child [list set x 1]
child eval set x
} -cleanup {interp delete child} -result 1
test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup {
interp create -safe child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
dde eval child [list [list set x 1]]
child eval set x
} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"}
# -------------------------------------------------------------------------
test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup {
set name ch\xEDld-9.1
set child [createChildProcess $name -handler Handler1]
file copy -force script1.tcl dde-script.tcl
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
update
file delete -force -- dde-script.tcl
} -result {null data}
# -------------------------------------------------------------------------
#cleanup
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
update
file delete -force -- dde-script.tcl
} -result {null data}
# -------------------------------------------------------------------------
#cleanup
#catch {interp delete $child}; # ensure we clean up the child.
file delete -force $::scriptName
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/winFCmd.test.
1 2 3 4 5 6 | # This file tests the tclWinFCmd.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 41 |
# This file tests the tclWinFCmd.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.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# 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.
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]]
# Initialise the test constraints
testConstraint winVista 0
testConstraint winXP 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint cdrom 0
testConstraint exdev 0
testConstraint longFileNames 0
# 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)]}]
testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}]
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
# low-level posix emulation layer.
test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body {
testfile mv $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
| | | | | | 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 |
# low-level posix emulation layer.
test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body {
testfile mv $cdfile $cdrom/dummy~~.fil
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1/td2/td3
file mkdir td2
testfile mv td2 td1/td2
} -returnCodes error -result EEXIST
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
testfile mv / td1
} -returnCodes error -result EINVAL
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
testfile mv td1 td1/td2
} -returnCodes error -result EINVAL
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
createfile tf1
testfile mv tf1 td1
} -returnCodes error -result EISDIR
test winFCmd-1.6 {TclpRenameFile: errno: ENOENT} -setup {
cleanup
} -constraints {win testfile} -body {
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
cleanup
} -constraints {win testfile} -body {
createfile tf1
testfile mv tf1 $longname
} -returnCodes error -result ENAMETOOLONG
test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup {
cleanup
| | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
cleanup
} -constraints {win testfile} -body {
createfile tf1
testfile mv tf1 $longname
} -returnCodes error -result ENAMETOOLONG
test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
testfile mv [pwd]/td1 td1/td2
} -returnCodes error -result EINVAL
test winFCmd-1.24 {TclpRenameFile: move a root dir} -setup {
cleanup
} -constraints {win testfile} -body {
testfile mv / c:/
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
} -constraints {win testfile} -body {
file mkdir td1
createfile tf1
testfile mv td1 tf1
} -returnCodes error -result ENOTDIR
test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup {
cleanup
| | | | | 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 |
} -constraints {win testfile} -body {
file mkdir td1
createfile tf1
testfile mv td1 tf1
} -returnCodes error -result ENOTDIR
test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
file mkdir td2/td2
testfile mv td1 td2
} -returnCodes error -result EEXIST
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
file mkdir td2/td2
testfile mv td1 td2
} -returnCodes error -result EEXIST
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1/td2
file mkdir td2
testfile mv td1 td2
list [file exists td1] [file exists td2] [file exists td2/td2]
} -result {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
-constraints {win exdev testfile testchmod} -body {
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
createfile tf1
testfile mv td1 tf1
} -cleanup {
cleanup
} -returnCodes error -result ENOTDIR
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup {
cleanup
| | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
createfile tf1
testfile mv td1 tf1
} -cleanup {
cleanup
} -returnCodes error -result ENOTDIR
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
file mkdir td1
createfile tf1
testfile mv tf1 td1
} -cleanup {
cleanup
} -returnCodes error -result EISDIR
test winFCmd-1.36 {TclpRenameFile: src and dst not dir} -setup {
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
if {$ndx > 50000} {
return -code error "limit reached without finding a collistion."
}
set filename [file join $dirname Test[incr ndx]]
set f [open $filename w]
close $f
file stat $filename stat
| | | | 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 |
if {$ndx > 50000} {
return -code error "limit reached without finding a 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} -body {
file mkdir td1
foreach {a b} [MakeFiles td1] break
file rename -force $a $b
file exists $a
} -cleanup {
cleanup
} -result {0}
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
list [file type td1] [file type td2]
} -cleanup {
cleanup
} -result {directory directory}
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
| | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
list [file type td1] [file type td2]
} -cleanup {
cleanup
} -result {directory directory}
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod knownMsvcBug notInCIenv} -body {
file mkdir td1
testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
cleanup
} -constraints {win testfile} -body {
createfile tf1
list [catch {testfile rmdir tf1} msg] [file tail $msg]
} -result {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
cleanup
| | | | | 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 |
cleanup
} -constraints {win testfile} -body {
createfile tf1
list [catch {testfile rmdir tf1} msg] [file tail $msg]
} -result {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod knownMsvcBug notInCIenv} -body {
file mkdir td1
testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
catch {testchmod 0o666 td1}
cleanup
} -result {td1 EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
} -constraints {win testfile notInCIenv} -body {
testfile rmdir /
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
} -constraints {winVista testfile testchmod knownMsvcBug notInCIenv} -body {
file mkdir td1
testchmod 0 td1
testfile rmdir td1
file exists td1
} -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
} -constraints {win testfile} -body {
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} -result {}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
| | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
} -constraints {win testfile} -body {
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} -result {}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
} -constraints {winVista testfile testchmod knownMsvcBug notInCIenv} -body {
file mkdir td1/td2
testchmod 0 td1
testfile rmdir -force td1
file exists td1
} -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 |
cleanup
} -body {
createfile td1 {}
list [file attributes td1 -archive 1] [file attributes td1 -archive]
} -cleanup {
cleanup
} -result {{} 1}
| | | | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
cleanup
} -body {
createfile td1 {}
list [file attributes td1 -archive 1] [file attributes td1 -archive]
} -cleanup {
cleanup
} -result {{} 1}
test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
list [file attributes td1 -archive 0] [file attributes td1 -archive]
} -cleanup {
cleanup
} -result {{} 0}
test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
list [file attributes td1 -hidden 1] [file attributes td1 -hidden] \
[file attributes td1 -hidden 0]
} -cleanup {
cleanup
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 |
cleanup
} -constraints {win} -body {
createfile td1 {}
list [file attributes td1 -readonly 0] [file attributes td1 -readonly]
} -cleanup {
cleanup
} -result {{} 0}
| | | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 |
cleanup
} -constraints {win} -body {
createfile td1 {}
list [file attributes td1 -readonly 0] [file attributes td1 -readonly]
} -cleanup {
cleanup
} -result {{} 0}
test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
list [file attributes td1 -system 1] [file attributes td1 -system]
} -cleanup {
cleanup
} -result {{} 1}
|
| ︙ | ︙ |
Changes to tests/winFile.test.
1 2 3 4 5 6 | # This file tests the tclWinFile.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 |
# This file tests the tclWinFile.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.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
glob ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body {
# The administrator account should always exist.
glob ~administrator
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
file delete $fname
close [open $fname w]
}
test winFile-4.0 {
Enhanced NTFS user/group permissions: test no acccess
} -constraints {
| | | | | 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 |
file delete $fname
close [open $fname w]
}
test winFile-4.0 {
Enhanced NTFS user/group permissions: test no acccess
} -constraints {
win notNTFS notWine
} -setup {
set owner [getuser $fname]
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
# Clean out all well-known ACLs
catch {cacls $fname /E /R "Everyone"} result
catch {cacls $fname /E /R $user} result
catch {cacls $fname /E /R $owner} result
cacls $fname /E /P $user:N
test_access $fname 0 0
} -result {}
test winFile-4.1 {
Enhanced NTFS user/group permissions: test readable only
} -constraints {
win notNTFS notWine
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
cacls $fname /E /P $user:N
cacls $fname /E /G $user:R
test_access $fname 1 0
} -result {}
test winFile-4.2 {
Enhanced NTFS user/group permissions: test writable only
} -constraints {
win notNTFS notWine
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
catch {cacls $fname /E /R $user} result
cacls $fname /E /P $user:N
cacls $fname /E /G $user:W
test_access $fname 0 1
|
| ︙ | ︙ |
Changes to tests/winNotify.test.
1 2 3 4 5 6 | # This file tests the tclWinNotify.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 |
# This file tests the tclWinNotify.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.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 testeventloop [expr {[info commands testeventloop] != {}}]
# There is no explicit test for InitNotifier or NotifierExitHandler
test winNotify-1.1 {Tcl_SetTimer: positive timeout} {win} {
set done 0
|
| ︙ | ︙ |
Changes to tests/winPipe.test.
1 2 3 4 5 6 7 8 | # # winPipe.test -- # # This file contains a collection of tests for tclWinPipe.c # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output (except for one message) 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 |
#
# winPipe.test --
#
# This file contains a collection of tests for tclWinPipe.c
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output (except for one message) means no errors were found.
#
# Copyright © 1996 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
set ::tcltestlib [info loaded {} Tcltest]
}
set org_pwd [pwd]
set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# several test-cases here expect current directory == [temporaryDirectory]:
cd [temporaryDirectory]
testConstraint exec [llength [info commands exec]]
testConstraint cat32 [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
| | | | | | 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 |
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept float_underflow"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept access_violation"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept illegal_instruction"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
puts $f "testexcept ctrl+c"
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \
-constraints {win exec slowTest} -body {
_testExecArgs 1 {*}$injectList
} -result {}
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \
| | | | | 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 |
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \
-constraints {win exec slowTest} -body {
_testExecArgs 1 {*}$injectList
} -result {}
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \
-constraints {win exec notWine} -body {
_testExecArgs 0 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
[list START {*}$injectList "\"END"] \
[list "START\"" {*}$injectList "\"END"]
} -result {}
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \
-constraints {win exec notWine} -body {
_testExecArgs 2 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
[list START {*}$injectList "\"END"] \
[list "START\"" {*}$injectList "\"END"]
} -result {}
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \
-constraints {win exec notWine} -body {
set lst {}
set maps {
{\&|^<>!()%}
{\&|^<>!()% }
{"\&|^<>!()%}
{"\&|^<>!()% }
{"""""\\\\\&|^<>!()%}
|
| ︙ | ︙ |
Changes to tests/winTime.test.
1 2 3 4 5 6 | # This file tests the tclWinTime.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 |
# This file tests the tclWinTime.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.
#
# Copyright © 1997 Sun Microsystems, Inc.
# 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.
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 testwinclock [llength [info commands testwinclock]]
# 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)]}]
# The next two tests will crash on Windows if the check for negative
# clock values is not done properly.
test winTime-1.1 {TclpGetDate} {win} {
set ::env(TZ) JST-9
set result [clock format -1 -format %Y]
|
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock notInCIenv} {
# May fail due to OS/hardware discrepancies. See:
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
|
| ︙ | ︙ |
Changes to tests/zipfs.test.
1 2 3 4 5 6 | # The file tests the tclZlib.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 41 |
# The file tests the tclZlib.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.
#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint zipfs [expr {
[llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]]
}]
testConstraint zipfslib 1
# Removed in tip430 - zipfs is no longer a static package
#test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
# load {} zipfs
#} -result {}
set ziproot [zipfs root]
set CWD [pwd]
set tmpdir [file join $CWD tmp]
file mkdir $tmpdir
test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
package require tcl::zipfs
} -result {2.0}
test zipfs-0.1 {zipfs basics} -constraints zipfs -body {
expr {${ziproot} in [file volumes]}
} -result 1
if {![string match ${ziproot}* $tcl_library]} {
###
|
| ︙ | ︙ |
Changes to tests/zlib.test.
1 2 3 4 5 6 | # The file tests the tclZlib.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 |
# The file tests the tclZlib.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.
#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint zlib [llength [info commands zlib]]
testConstraint recentZlib 0
catch {
# Work around a bug in some versions of zlib; known to manifest on at
|
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
package present tcl::zlib
} -result 2.0.1
test zlib-2.1 {zlib compress/decompress} zlib {
zlib decompress [zlib compress abcdefghijklm]
} abcdefghijklm
test zlib-3.1 {zlib deflate/inflate} zlib {
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
set s [zlib stream deflate]
$s put {}
} -cleanup {
catch {$s close}
} -result ""
# Also causes Tk Bug 10f2e7872b
test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
| | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
set s [zlib stream deflate]
$s put {}
} -cleanup {
catch {$s close}
} -result ""
# Also causes Tk Bug 10f2e7872b
test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
expr {srand(12345)}
set randdata {}
for {set i 0} {$i<6001} {incr i} {
append randdata [binary format c [expr {int(256*rand())}]]
}
} -body {
set strm [zlib stream compress]
for {set i 1} {$i<3000} {incr i} {
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup {
# Actual data isn't very important; needs to be substantially larger than
# the internal buffer (32kB) and incompressible.
set largeData {}
| | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 |
catch {close $inSide}
catch {$strm close}
} -result {358 358}
test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup {
# Actual data isn't very important; needs to be substantially larger than
# the internal buffer (32kB) and incompressible.
set largeData {}
for {set i 0;expr {srand(1)}} {$i < 100000} {incr i} {
append largeData [lindex "a b c d e f g h i j k l m n o p" \
[expr {int(16*rand())}]]
}
set file [makeFile {} test.gz]
} -constraints zlib -body {
set f [open $file wb]
fconfigure $f -buffering none
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 |
set ::total
} -cleanup {
close $srv
rename bgerror {}
rename zlibRead {}
} -result {error {invalid block type}}
| | | | 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 |
set ::total
} -cleanup {
close $srv
rename bgerror {}
rename zlibRead {}
} -result {error {invalid block type}}
test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f] [string repeat "hello" 1000]
close $f
set f [open $file rb]
set d [read $f]
close $f
set d [zlib gunzip $d]
list [regexp -all "hello" $d] [string length [regsub -all "hello" $d {}]]
} -cleanup {
removeFile $file
} -result {1000 0}
test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup {
set file [makeFile {} test.input]
} -constraints zlib -body {
set f [open $file wb]
puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
[string repeat "hello" 1000]
close $f
set f [open $file rb]
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
close $fout
}
file size $filedst
} -cleanup {
removeFile $filesrc
removeFile $filedst
} -result 56
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
close $fout
}
file size $filedst
} -cleanup {
removeFile $filesrc
removeFile $filedst
} -result 56
set zlibbinf ""
proc _zlibbinf {} {
# inlined zlib.bin file creator:
variable zlibbinf
if {$zlibbinf eq ""} {
set zlibbinf [makeFile {} test-zlib-13.bin]
set f [open $zlibbinf wb]
puts -nonewline $f [zlib decompress [binary decode base64 {
eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm
/+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15
4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA==
}]]
close $f
}
return $zlibbinf
}
test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup {
set pathin [_zlibbinf]
set chanin [open $pathin rb]
set pathout [makeFile {} test-zlib-13.deflated]
set chanout [open $pathout wb]
zlib push inflate $chanin
fcopy $chanin $chanout
close $chanin
close $chanout
} -body {
file size $pathout
} -cleanup {
removeFile $pathout
unset chanin pathin chanout pathout
} -result 458752
test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup {
# Start from the basic asset
set pathin [_zlibbinf]
set chanin [open $pathin rb]
# Create a multi-stream by copying the asset twice into it.
set pathout [makeFile {} test-zlib-13.multi]
set chanout [open $pathout wb]
fcopy $chanin $chanout
seek $chanin 0 start
fcopy $chanin $chanout
close $chanin
close $chanout
# The multi-stream file shall be our input
set pathin $pathout
set chanin [open $pathin rb]
# And our destinations
set pathout1 [makeFile {} test-zlib-13.multi-1]
set pathout2 [makeFile {} test-zlib-13.multi-2]
} -body {
# Decode first stream
set chanout [open $pathout1 wb]
zlib push inflate $chanin
fcopy $chanin $chanout
chan pop $chanin
close $chanout
# Decode second stream
set chanout [open $pathout2 wb]
zlib push inflate $chanin
fcopy $chanin $chanout
chan pop $chanin
close $chanout
#
list [file size $pathout1] [file size $pathout2]
} -cleanup {
close $chanin
removeFile $pathout
removeFile $pathout1
removeFile $pathout2
unset chanin pathin chanout pathout pathout1 pathout2
} -result {458752 458752}
if {$zlibbinf ne ""} {
removeFile $zlibbinf
}
unset zlibbinf
rename _zlibbinf {}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Deleted tools/Makefile.in.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added tools/addVerToFile.tcl.
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 |
#!/usr/bin/env tclsh
if {$argc < 1} {
error "need a filename argument"
}
lassign $argv filename
set f [open $filename a]
puts $f "TCL_VERSION=[info tclversion]"
puts $f "TCL_PATCHLEVEL=[info patchlevel]"
close $f
|
Changes to tools/checkLibraryDoc.tcl.
1 2 3 4 5 | # checkLibraryDoc.tcl -- # # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list | | | | 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 |
# checkLibraryDoc.tcl --
#
# This script attempts to determine what APIs exist in the source base that
# have not been documented. By grepping through all of the doc/*.3 man
# pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list
# against the list of Pkg_ APIs found in the source (e.g., tcl8.7/*/*.[ch])
# we create six lists:
# 1) APIs in Source not in Docs.
# 2) APIs in Docs not in Source.
# 3) Internal APIs and structs.
# 4) Misc APIs and structs that we are not documenting.
# 5) Command APIs (e.g., Tcl_ArrayObjCmd.)
# 6) Proc pointers (e.g., Tcl_CloseProc.)
#
# Note: Each list is "a best guess" approximation. If developers write
# non-standard code, this script will produce erroneous results. Each
# list should be carefully checked for accuracy.
#
# Copyright (c) 1998-1999 Scriptics Corporation.
# All rights reserved.
lappend auto_path "c:/program\ files/tclpro1.2/win32-ix86/bin"
#lappend auto_path "/home/surles/cvs/tclx8.0/tcl/unix"
if {[catch {package require Tclx}]} {
puts "error: could not load TclX. Please set TCL_LIBRARY."
|
| ︙ | ︙ | |||
65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
Tk_ErrorHandler \
Tk_FakeWin \
Tk_Font \
Tk_FontMetrics \
Tk_GeomMgr \
Tk_Image \
Tk_ImageMaster \
Tk_ImageType \
Tk_Item \
Tk_ItemType \
Tk_OptionSpec\
Tk_OptionTable \
Tk_OptionType \
Tk_PhotoHandle \
| > | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
Tk_ErrorHandler \
Tk_FakeWin \
Tk_Font \
Tk_FontMetrics \
Tk_GeomMgr \
Tk_Image \
Tk_ImageMaster \
Tk_ImageModel \
Tk_ImageType \
Tk_Item \
Tk_ItemType \
Tk_OptionSpec\
Tk_OptionTable \
Tk_OptionType \
Tk_PhotoHandle \
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
global argv0
global argv
set len [llength $argv]
if {($len != 2) && ($len != 3)} {
puts "usage: $argv0 pkgName pkgDir \[outFile\]"
puts " pkgName == Tcl,Tk"
| < | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
global argv0
global argv
set len [llength $argv]
if {($len != 2) && ($len != 3)} {
puts "usage: $argv0 pkgName pkgDir \[outFile\]"
puts " pkgName == Tcl,Tk"
exit 1
}
set pkg [lindex $argv 0]
set dir [lindex $argv 1]
if {[llength $argv] == 3} {
set file [open [lindex $argv 2] w]
|
| ︙ | ︙ |
Deleted tools/configure.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/configure.ac.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tools/encoding/Makefile.
1 | # | | | 1 2 3 4 5 6 7 8 9 | # # This file is a Makefile to compile all the encoding files. # # Run "make" to compile all the encoding files (*.txt,*.esc) into the # format that Tcl can use (*.enc). It is your responsibility to move the # encoding files to the appropriate place ($TCL_ROOT/library/encoding # # The .txt files in this directory come from the Unicode CD and are covered # by the following copyright notice: |
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | # # Recipient is granted the right to make copies in any form for # internal distribution and to freely use the information supplied # in the creation of products supporting Unicode. Unicode, Inc. # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # | | | | | | | 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 | # # Recipient is granted the right to make copies in any form for # internal distribution and to freely use the information supplied # in the creation of products supporting Unicode. Unicode, Inc. # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # # In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # #---------------------------------------------------------------------------- # # The txt2enc program built by this makefile is used to compile individual # .txt files into .enc files, the format that Tcl understands for encoding # files. This compilation to a different format is allowed by the above # restriction. # # The files shiftjis.txt and jis0208.txt were modified from the original # ones provided on the Unicode CD. The double-width backslash character # 0x815F in these two Japanese encodings was being mapped to Unicode 005C # (REVERSE SOLIDUS), the normal backslash character. They have been # changed to map 0x815F to Unicode FF3C (FULLWIDTH REVERSE SOLIDUS) and let # the regular backslash character map to itself. This follows how cp932 # behaves. # # Copyright (c) 1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: @(#) Makefile 1.1 98/01/28 11:41:36 # EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt encodings: clean txt2enc $(EUC_ENCODINGS) @echo Compiling encoding files. @for p in *.esc; do \ base=`echo $$p | sed 's/\..*$$//'`; \ echo $$base.enc; \ echo "# Encoding file: $$base, escape-driven" > $$base.enc; \ echo "E" >> $$base.enc; \ cat $$p >> $$base.enc; \ done @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -e 0 -u 1 $$p > $$enc; \ done @echo @echo Compiling special versions of encoding files. @for p in ascii.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ ./txt2enc -m $$p > $$enc; \ done @for p in jis0208.txt; do \ |
| ︙ | ︙ |
Changes to tools/encoding/big5.txt.
1 2 3 4 | # big5.txt -- # # BIG5 to Unicode table (modified) # | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # big5.txt -- # # BIG5 to Unicode table (modified) # # Copyright (c) 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. # # NOTE: this table has been modified to include the 7-bit ASCII # characters that are allowed in BIG5 files. # |
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | # # General notes: # # This table contains the data Metis and Taligent currently have on how # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility | | | | | | | | | 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 | # # General notes: # # This table contains the data Metis and Taligent currently have on how # BIG5 characters map into Unicode. # # WARNING! It is currently impossible to provide round-trip compatibility # between BIG5 and Unicode. # # A number of characters are not currently mapped because # of conflicts with other mappings. They are as follows: # # BIG5 Description Comments # # 0xA15A SPACING UNDERSCORE duplicates A1C4 # 0xA1C3 SPACING HEAVY OVERSCORE not in Unicode # 0xA1C5 SPACING HEAVY UNDERSCORE not in Unicode # 0xA1FE LT DIAG UP RIGHT TO LOW LEFT duplicates A2AC # 0xA240 LT DIAG UP LEFT TO LOW RIGHT duplicates A2AD # 0xA2CC HANGZHOU NUMERAL TEN conflicts with A451 mapping # 0xA2CE HANGZHOU NUMERAL THIRTY conflicts with A4CA mapping # # We currently map all of these characters to U+FFFD REPLACEMENT CHARACTER. # It is also possible to map these characters to their duplicates, or to # the user zone. # # Notes: # # 1. In addition to the above, there is some uncertainty about the # mappings in the range C6A1 - C8FE, and F9DD - F9FE. The ETEN # version of BIG5 organizes the former range differently, and adds # additional characters in the latter range. The correct mappings # these ranges need to be determined. # # 2. There is an uncertainty in the mapping of the Big Five character # 0xA3BC. This character occurs within the Big Five block of tone marks # for bopomofo and is intended to be the tone mark for the first tone in # Mandarin Chinese. We have selected the mapping U+02C9 MODIFIER LETTER # MACRON (Mandarin Chinese first tone) to reflect this semantic. # However, because bopomofo uses the absense of a tone mark to indicate # the first Mandarin tone, most implementations of Big Five represent # this character with a blank space, and so a mapping such as U+2003 EM SPACE # might be preferred. # # # # Format: Three tab-separated columns # Column #1 is the BIG5 code (in hex as 0xXXXX) # Column #2 is the Unicode (in hex as 0xXXXX) # Column #3 is the Unicode name (follows a comment sign, '#') # The official names for Unicode characters U+4E00 # to U+9FA5, inclusive, is "CJK UNIFIED IDEOGRAPH-XXXX", |
| ︙ | ︙ |
Changes to tools/encoding/gb2312.txt.
1 2 3 4 | # gb2312.txt -- # # GB2312 to Unicode table (modified) # | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # gb2312.txt -- # # GB2312 to Unicode table (modified) # # Copyright (c) 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. # # NOTE: this table has been modified to include the 7-bit ASCII # characters that are allowed in GB2312 files. # |
| ︙ | ︙ |
Changes to tools/encoding/jis0212.txt.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | # # Any comments or problems, contact <John_Jenkins@taligent.com> # # Notes: # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: | | | | 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 | # # Any comments or problems, contact <John_Jenkins@taligent.com> # # Notes: # # 1. JIS X 0212 apparently unified the following two symbols # into a single character at 0x2922: # # LATIN CAPITAL LETTER D WITH STROKE # LATIN CAPITAL LETTER ETH # # However, JIS X 0212 maintains the distinction between # the lowercase forms of these two elements at 0x2942 and 0x2943. # Given the structre of these JIS encodings, it is clear that # 0x2922 and 0x2942 are intended to be a capital/small pair. # Consequently, in the Unicode mapping, 0x2922 is treated as # LATIN CAPITAL LETTER D WITH STROKE. # 0x222F 0x02D8 # BREVE 0x2230 0x02C7 # CARON (Mandarin Chinese third tone) 0x2231 0x00B8 # CEDILLA 0x2232 0x02D9 # DOT ABOVE (Mandarin Chinese light tone) 0x2233 0x02DD # DOUBLE ACUTE ACCENT 0x2234 0x00AF # MACRON 0x2235 0x02DB # OGONEK |
| ︙ | ︙ |
Changes to tools/encoding/ksc5601.txt.
1 2 3 4 5 6 7 | # What is enclosed below is the mapping between KS C 5601-1987 # and Unicode 2.0. It's automatically generated from KSC5601.TXT # (at ftp://ftp.unicode.org/Public/MAPPING/EASTASIA/KSC) which is # actually NOT the mapping between KS C 5601-1992 and Unicode 2.0 # BUT the mapping table between UHC(Microsoft Unified Hangul Code) # and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.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 |
# What is enclosed below is the mapping between KS C 5601-1987
# and Unicode 2.0. It's automatically generated from KSC5601.TXT
# (at ftp://ftp.unicode.org/Public/MAPPING/EASTASIA/KSC) which is
# actually NOT the mapping between KS C 5601-1992 and Unicode 2.0
# BUT the mapping table between UHC(Microsoft Unified Hangul Code)
# and Unicode 2.0. Hence, in this pacakge, I renamed it as UHC.TXT
#
# The Unix command used is
# egrep '^0x' < KSC5601.TXT | \
# egrep -v '^0x([8-9]...|A0..|..[4-9].|..A0)' | perl tab.pl
#
# where tab.pl is as following
#----------tab.pl
# $n=0;
# while (<>) {
# local($euck, $ucs4, @rest) = split;
# local($u)=hex($ucs4);
# local($k)=hex($euck);
# printf ("0x%04X 0x%04X %s\n",$k-0x8080, $u,join(' ',@rest));
# }
#
# Column #1 : KS C 5601-1987(KS C 5601-1992 excluding addtional Hangul
# syllables defined for Johab encoding in Annex 3)
# in hex as 0xXXXX
# Column #2 : the Unicode (in hex as 0xXXXX)
# Column #3 : the Unicode name (following a comment sign, '#')
# The number of characters enumerated in this table is 8824, the
# as listed in KS C 5601-987
#
#
# The entries are in KS C 5601-1987 order
# You can use the following algorithms to convert the hex form
# of KS C 5601 to other forms
# To get EUCKorea(EUC-KR) code points, add 0x8080.
# To get row(Hang) and column(Yol) as used in KS C 5601-1987 manual,
# first subtract 0x2020. Then
# the high and low bytes correspond to the row(Hang) and the column(Yol),
|
| ︙ | ︙ |
Changes to tools/encoding/macCentEuro.txt.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macCroatian.txt.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macCyrillic.txt.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macGreek.txt.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macIceland.txt.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macRoman.txt.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/macTurkish.txt.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | # throughout this document, "Macintosh" can be used to refer to # Macintosh computers and "Unicode" can be used to refer to the # Unicode standard. # # Apple makes no warranty or representation, either express or # implied, with respect to these tables, their quality, accuracy, or # fitness for a particular purpose. In no event will Apple be liable # for direct, indirect, special, incidental, or consequential damages # resulting from any defect or inaccuracy in this document or the # accompanying tables. # # These mapping tables and character lists are subject to change. # The latest tables should be available from the following: # # <ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> |
| ︙ | ︙ |
Changes to tools/encoding/shiftjis.txt.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | # The entries are ordered by their Shift-JIS codes as follows: # Single-byte characters precede double-byte characters # The single-byte and double-byte blocks are in ascending # hexadecimal order # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | # The entries are ordered by their Shift-JIS codes as follows: # Single-byte characters precede double-byte characters # The single-byte and double-byte blocks are in ascending # hexadecimal order # There is an alternative order some people might be preferred, # where all the entries are in order of the top (or only) byte. # This alternate order can be generated from the one given here # by a simple sort. # # The kanji mappings are a normative part of ISO/IEC 10646. The # non-kanji mappings are provisional, pending definition of # official mappings by Japanese standards bodies # # Any comments or problems, contact <John_Jenkins@taligent.com> # |
| ︙ | ︙ |
Changes to tools/encoding/tis-620.txt.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | 0xA4 0x0E04 #THAI CHARACTER KHO KHWAI 0xA5 0x0E05 #THAI CHARACTER KHO KHON 0xA6 0x0E06 #THAI CHARACTER KHO RAKHANG 0xA7 0x0E07 #THAI CHARACTER NGO NGU 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | 0xA4 0x0E04 #THAI CHARACTER KHO KHWAI 0xA5 0x0E05 #THAI CHARACTER KHO KHON 0xA6 0x0E06 #THAI CHARACTER KHO RAKHANG 0xA7 0x0E07 #THAI CHARACTER NGO NGU 0xA8 0x0E08 #THAI CHARACTER CHO CHAN 0xA9 0x0E09 #THAI CHARACTER CHO CHING 0xAA 0x0E0A #THAI CHARACTER CHO CHANG 0xAB 0x0E0B #THAI CHARACTER SO SO 0xAC 0x0E0C #THAI CHARACTER CHO CHOE 0xAD 0x0E0D #THAI CHARACTER YO YING 0xAE 0x0E0E #THAI CHARACTER DO CHADA 0xAF 0x0E0F #THAI CHARACTER TO PATAK 0xB0 0x0E10 #THAI CHARACTER THO THAN 0xB1 0x0E11 #THAI CHARACTER THO NANGMONTHO 0xB2 0x0E12 #THAI CHARACTER THO PHUTHAO |
| ︙ | ︙ |
Changes to tools/encoding/txt2enc.c.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
| | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
lo = enc & 0xFF;
if (toUnicode[hi] == NULL) {
toUnicode[hi] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[hi], 0, 256 * sizeof(Rune));
}
toUnicode[hi][lo] = uni;
}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
for (i = 0x7F; i < 0xA0; i++) {
if (toUnicode[i] == NULL && toUnicode[0][i] == 0) {
toUnicode[0][i] = i;
}
}
}
}
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
| | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
if ((lo & 0x0F) == 0x0F) {
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
|
| ︙ | ︙ |
Deleted tools/eolFix.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tools/genStubs.tcl.
1 2 3 4 5 6 | # genStubs.tcl -- # # This script generates a set of stub files for a given # interface. # # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# genStubs.tcl --
#
# This script generates a set of stub files for a given
# interface.
#
#
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval genStubs {
# libraryName --
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
proc genStubs::rewriteFile {file text} {
if {![file exists $file]} {
puts stderr "Cannot find file: $file"
return
}
set in [open ${file} r]
set out [open ${file}.new w]
| | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
proc genStubs::rewriteFile {file text} {
if {![file exists $file]} {
puts stderr "Cannot find file: $file"
return
}
set in [open ${file} r]
set out [open ${file}.new w]
fconfigure $out -translation lf -encoding utf-8
while {![eof $in]} {
set line [gets $in]
if {[string match "*!BEGIN!*" $line]} {
break
}
puts $out $line
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
set line "$rtype"
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
| > | > | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
set line "$rtype"
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
if {$count >= 0} {
append line [string range "\t\t\t" 0 $count]
}
set pad [expr {24 - [string length $line]}]
if {$pad <= 0} {
append line " "
set pad 0
}
if {$args eq ""} {
append line $fname
|
| ︙ | ︙ |
Changes to tools/index.tcl.
1 2 3 4 5 6 | # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # # 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. # Global variables used by these scripts: # # state - state variable that controls action of text proc. |
| ︙ | ︙ |
Changes to tools/installData.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # This file installs a hierarchy of data found in the directory # specified by its first argument into the directory specified # by its second. # #---------------------------------------------------------------------- # | | | | | 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 |
#
# This file installs a hierarchy of data found in the directory
# specified by its first argument into the directory specified
# by its second.
#
#----------------------------------------------------------------------
#
# Copyright (c) 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.
#----------------------------------------------------------------------
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
}
}
copyDir [file normalize [lindex $argv 0]] [file normalize [lindex $argv 1]]
|
Changes to tools/installVfs.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 |
#!/bin/sh
#\
exec tclsh "$0" ${1+"$@"}
#----------------------------------------------------------------------
#
# installVfs.tcl --
#
# This file wraps the /library file system around a binary
#
#----------------------------------------------------------------------
#
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
#!/bin/sh
#\
exec tclsh "$0" ${1+"$@"}
#----------------------------------------------------------------------
#
# installVfs.tcl --
#
# This file wraps the /library file system around a binary
#
#----------------------------------------------------------------------
#
# Copyright (c) 2018 Sean Woods. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
proc mapDir {resultvar prefix filepath} {
upvar 1 $resultvar result
if {![info exists result]} {
|
| ︙ | ︙ |
Changes to tools/loadICU.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | # None. # # Side effects: # Creates the message catalogs. # #---------------------------------------------------------------------- # | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # None. # # Side effects: # Creates the message catalogs. # #---------------------------------------------------------------------- # # Copyright (c) 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. #---------------------------------------------------------------------- puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences" exit; # Remove those two lines after modifying this tool. |
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
#----------------------------------------------------------------------
proc backslashify { string } {
set retval {}
foreach char [split $string {}] {
scan $char %c ccode
| | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
#----------------------------------------------------------------------
proc backslashify { string } {
set retval {}
foreach char [split $string {}] {
scan $char %c ccode
if { $ccode >= 0x20 && $ccode < 0x7F && $char ne "\""
&& $char ne "\{" && $char ne "\}" && $char ne "\["
&& $char ne "\]" && $char ne "\\" && $char ne "\$" } {
append retval $char
} else {
append retval \\u [format %04x $ccode]
}
}
|
| ︙ | ︙ |
Changes to tools/makeHeader.tcl.
1 2 3 4 5 6 7 8 9 10 | # makeHeader.tcl -- # # This script generates embeddable C source (in a .h file) from a .tcl # script. # # Copyright (c) 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. | | | | 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 |
# makeHeader.tcl --
#
# This script generates embeddable C source (in a .h file) from a .tcl
# script.
#
# Copyright (c) 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.
package require Tcl 8.6-
namespace eval makeHeader {
####################################################################
#
# mapSpecial --
# Transform a single line so that it is able to be put in a C string.
#
proc mapSpecial {str} {
# All Tcl metacharacters and key C backslash sequences
set MAP {
\" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
\a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
}
set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
subst [regsub -all {[^\x20-\x7E]} [string map $MAP $str] $XFORM]
}
####################################################################
#
# compactLeadingSpaces --
# Converts the leading whitespace on a line into a more compact form.
#
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 | set BEGIN "*!BEGIN!: Do not edit below this line.*" set END "*!END!: Do not edit above this line.*" upvar 1 $dataVar data set from [lsearch -glob $data $BEGIN] set to [lsearch -glob $data $END] | | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
set BEGIN "*!BEGIN!: Do not edit below this line.*"
set END "*!END!: Do not edit above this line.*"
upvar 1 $dataVar data
set from [lsearch -glob $data $BEGIN]
set to [lsearch -glob $data $END]
if {$from < 0 || $to < 0 || $from >= $to} {
throw BAD "not a template"
}
set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
}
####################################################################
|
| ︙ | ︙ |
Changes to tools/makeTestCases.tcl.
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
puts $f2 " }"
puts $f2 "} ok"
foreach row $TZData(:America/Detroit) {
foreach { t offset isdst tzname } $row break
if { $t > -4000000000000 } {
set conds [list detroit]
| | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
puts $f2 " }"
puts $f2 "} ok"
foreach row $TZData(:America/Detroit) {
foreach { t offset isdst tzname } $row break
if { $t > -4000000000000 } {
set conds [list detroit]
if { $t > wide(0x7FFFFFFF) } {
set conds [list detroit y2038]
}
incr t -1
set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
-timezone :America/Detroit]
set r [clock format $t -format $fmt \
-timezone :America/Detroit]
|
| ︙ | ︙ |
Deleted tools/man2help.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/man2help2.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/man2html.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/man2html1.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/man2html2.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/man2tcl.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tools/mkVfs.tcl.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
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}} {
| | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
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"
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
# Results:
# Raw dependency list pairs.
proc readDepends {chan} {
set line ""
array set depends {}
| | | | 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 |
# 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] {
|
| ︙ | ︙ |
Changes to tools/regexpTestLib.tcl.
1 2 3 4 5 6 | # regexpTestLib.tcl -- # # This file contains tcl procedures used by spencer2testregexp.tcl and # spencer2regexp.tcl, which are programs written to convert Henry # Spencer's test suite to tcl test files. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# regexpTestLib.tcl --
#
# This file contains tcl procedures used by spencer2testregexp.tcl and
# spencer2regexp.tcl, which are programs written to convert Henry
# Spencer's test suite to tcl test files.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
proc readInputFile {} {
global inFileName
global lineArray
set fileId [open $inFileName r]
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
regsub -all {E} $currentLine {\\033} currentLine
regsub -all {F} $currentLine {\\f} currentLine
regsub -all {N} $currentLine {\\n} currentLine
# if and \r substitutions are made, do not wrap re, flags,
# str, and result in braces
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
regsub -all {E} $currentLine {\\033} currentLine
regsub -all {F} $currentLine {\\f} currentLine
regsub -all {N} $currentLine {\\n} currentLine
# if and \r substitutions are made, do not wrap re, flags,
# str, and result in braces
set noBraces [regsub -all {R} $currentLine {\\\x0D} currentLine]
regsub -all {T} $currentLine {\\t} currentLine
regsub -all {V} $currentLine {\\v} currentLine
if {[regexp {=} $flags] == 1} {
set re [lindex $currentLine 0]
}
set str [lindex $currentLine 2]
}
|
| ︙ | ︙ |
Deleted tools/str2c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tools/tcl.hpj.in.
|
| < < < < < < < < < < < < < < < < < < < |
Changes to tools/tclZIC.tcl.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | # # This program parses the timezone data in a means analogous to the # 'zic' command, and produces Tcl time zone information files suitable # for loading into the 'clock' namespace. # #---------------------------------------------------------------------- # | | | | 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 |
#
# This program parses the timezone data in a means analogous to the
# 'zic' command, and produces Tcl time zone information files suitable
# for loading into the 'clock' namespace.
#
#----------------------------------------------------------------------
#
# Copyright (c) 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.
#----------------------------------------------------------------------
# Define the names of the Olson files that we need to load.
# We avoid the solar time files and the leap seconds.
set olsonFiles {
africa antarctica asia australasia
backward etcetera europe northamerica
southamerica
}
# Define the year at which the DST information will stop.
set maxyear 2100
# Determine how big a wide integer is.
|
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 | append data "\n " [list [list $time $offset $dst $name]] } append data \n # Write the data to the information file set f [open $fileName w] | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
append data "\n " [list [list $time $offset $dst $name]]
}
append data \n
# Write the data to the information file
set f [open $fileName w]
fconfigure $f -translation lf -encoding utf-8
puts $f "\# created by $::argv0 - do not edit"
puts $f ""
puts $f [list set TZData(:$zoneName) $data]
close $f
}
return
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 | set sourceCmd "\n [list LoadTimeZoneFile $linkTo]\n" set ifCmd [list if "!\[info exists TZData($linkTo)\]" $sourceCmd] set setCmd "set TZData(:$zoneName) \$TZData(:$linkTo)" # Write the file set f [open $fileName w] | | | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 |
set sourceCmd "\n [list LoadTimeZoneFile $linkTo]\n"
set ifCmd [list if "!\[info exists TZData($linkTo)\]" $sourceCmd]
set setCmd "set TZData(:$zoneName) \$TZData(:$linkTo)"
# Write the file
set f [open $fileName w]
fconfigure $f -translation lf -encoding utf-8
puts $f "\# created by $::argv0 - do not edit"
puts $f $ifCmd
puts $f $setCmd
close $f
}
return
|
| ︙ | ︙ |
Changes to tools/tcltk-man2html-utils.tcl.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
##
## templating
##
proc indexfile {} {
if {[info exists ::TARGET] && $::TARGET eq "devsite"} {
return "index.tml"
} else {
| | | | | < < < < | | | | > > > > | | > > > > | > > > | > | | > > > > > > | > > > > > > > > > > > > | > > > > > > > > > | > > > > > > > > | > | > | | > | | | | | | 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 |
##
## templating
##
proc indexfile {} {
if {[info exists ::TARGET] && $::TARGET eq "devsite"} {
return "index.tml"
} else {
return "index.html"
}
}
proc copyright {copyright {level {}}} {
# We don't actually generate a separate copyright page anymore
#set page "${level}copyright.html"
#return "<a href=\"$page\">Copyright</a> © [htmlize-text [lrange $copyright 2 end]]"
# obfuscate any email addresses that may appear in name
set who [string map {@ (at)} [lrange $copyright 2 end]]
return "Copyright © [htmlize-text $who]"
}
proc copyout {copyrights {level {}}} {
set count 0
set out "<div class=\"copy\">"
foreach c $copyrights {
if {$count > 0} {
append out <br>
}
append out "[copyright $c $level]\n"
incr count
}
append out "</div>"
return $out
}
proc CSS {{level ""}} {
return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n"
}
proc htmlhead {title header args} {
set level ""
if {[lindex $args end] eq "../[indexfile]"} {
# XXX hack - assume same level for CSS file
set level "../"
}
set out "<!DOCTYPE html>\n<html lang=\"en\">\n<head><meta charset=\"utf-8\"><title>$title</title>\n[CSS $level]</head>\n"
foreach {uptitle url} $args {
set header "<a href=\"$url\">$uptitle</a> <small>></small> $header"
}
append out "<body><h2>$header</h2>"
global manual
if {[info exists manual(subheader)]} {
set subs {}
foreach {name subdir} $manual(subheader) {
if {$name eq $title} {
lappend subs $name
} else {
lappend subs "<a href=\"${level}$subdir/[indexfile]\">$name</a>"
}
}
append out "\n<h3>[join $subs { | }]</h3>"
}
return $out
}
##
## parsing
##
proc unquote arg {
return [string map [list \" {}] $arg]
}
proc parse-directive {line codename restname} {
upvar 1 $codename code $restname rest
return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]
}
proc nospace-text {text} {
return [regsub -all " " $text _]
}
proc htmlize-text {text {charmap {}}} {
# contains some extras for use in nroff->html processing
# build on the list passed in, if any
lappend charmap \
"–" "–" \
{&} {&} \
{\\} "\" \
{\e} "\" \
{\ } { } \
{\|} { } \
{\0} { } \
\" {"} \
{<} {<} \
{>} {>} \
\u201C "“" \
\u201D "”"
return [string map $charmap $text]
}
proc process-text {text} {
global manual
# preprocess text; note that this is an incomplete map, and will probably
# need to have things added to it as the manuals expand to use them.
set charmap [list \
{\&} "\t" \
{\%} {} \
"\\\n" "\n" \
{\(r!} "¡" \
{\(ct} "¢" \
{\(Po} "£" \
{\(Cs} "¤" \
{\(Ye} "¥" \
{\(bb} "¦" \
{\(sc} "§" \
{\(ad} "¨" \
{\(co} "©" \
{\(Of} "ª" \
{\(Fo} "«" \
{\(no} "¬" \
{\(rg} "®" \
{\(a-} "¯" \
{\(de} "°" \
{\(+-} "±" \
{\(S2} "²" \
{\(S3} "³" \
{\(aa} "´" \
{\(mc} "µ" \
{\(ps} "¶" \
{\(pc} "·" \
{\(ac} "¸" \
{\(S1} "¹" \
{\(Om} "º" \
{\(Fc} "»" \
{\(14} "¼" \
{\(12} "½" \
{\(34} "¾" \
{\(r?} "¿" \
{\(AE} "Æ" \
{\(-D} "Ð" \
{\(mu} "×" \
{\(TP} "Þ" \
{\(ss} "ß" \
{\(ae} "æ" \
{\(Sd} "ð" \
{\(di} "÷" \
{\(Tp} "þ" \
{\(em} "—" \
{\(en} "–" \
{\(fm} "′" \
{\(mi} "−" \
{\(.i} "ı" \
{\(.j} "ȷ" \
{\(Fn} "ƒ" \
{\(OE} "Œ" \
{\(oe} "œ" \
{\(IJ} "IJ" \
{\(ij} "ij" \
{\(<-} "<font size=\"+1\">←</font>" \
{\(->} "<font size=\"+1\">→</font>" \
{\(eu} "€" \
{\fP} {\fR} \
{\.} . \
{\(bu} "•" \
{\*(qo} "ô" \
]
# This might make a few invalid mappings, but we don't use them
foreach c {a c e g i l n o s t u y z A C E G I L N O S T U Y Z} {
foreach {prefix suffix} {
o ring / slash : uml ' acute ^ circ ` grave ~ tilde , cedil v caron
} {
lappend charmap "\\\[${prefix}${c}\]" "&${c}${suffix};"
lappend charmap "\\(${prefix}${c}" "&${c}${suffix};"
}
}
lappend charmap {\-\|\-} -- ; # two hyphens
lappend charmap {\-} - ; # a hyphen
set text [htmlize-text $text $charmap]
# General quoted entity
regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text
while {[string first "\\" $text] >= 0} {
# C R
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
{\1<tt>\2</tt>\3} text]} continue
# B R
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
{\1<b>\2</b>\3} text]} continue
# B I
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
{\1<b>\2</b>\\fI\3} text]} continue
# I R
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
{\1<i>\2</i>\3} text]} continue
# I B
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
{\1<i>\2</i>\\fB\3} text]} continue
# B B, I I, R R
if {
[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
{\1\\fB\2\3} ntext]
|| [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
{\1\\fI\2\3} ntext]
|| [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
##
proc long-toc {text} {
global manual
set here M[incr manual(section-toc-n)]
set manual($manual(name)-id-$text) $here
set there L[incr manual(long-toc-n)]
lappend manual(section-toc) \
| | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
##
proc long-toc {text} {
global manual
set here M[incr manual(section-toc-n)]
set manual($manual(name)-id-$text) $here
set there L[incr manual(long-toc-n)]
lappend manual(section-toc) \
"<dd><a href=\"$manual(name).html#$here\" name=\"[nospace-text $there]\" id=\"[nospace-text $there]\">$text</a>"
return "<a name=\"[nospace-text $here]\" id=\"[nospace-text $here]\">$text</a>"
}
proc option-toc {name class switch} {
global manual
# Special case handling, oh we hate it but must do it
if {[string match "*OPTIONS" $manual(section)]} {
if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" ||
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
# link the defined standard option to the long table of contents and make
# a target for the standard option references from other man pages.
set first [lindex $switch 0]
set here M$first
set there L[incr manual(long-toc-n)]
set manual(standard-option-$manual(name)-$first) \
| | | | | | | | | | 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 |
# link the defined standard option to the long table of contents and make
# a target for the standard option references from other man pages.
set first [lindex $switch 0]
set here M$first
set there L[incr manual(long-toc-n)]
set manual(standard-option-$manual(name)-$first) \
"<a href=\"$manual(name).html#$here\">$switch, $name, $class</a>"
lappend manual(section-toc) \
"<dd><a href=\"$manual(name).html#$here\" name=\"[nospace-text $there]\" id=\"[nospace-text $there]\">$switch, $name, $class</a>"
return "<a name=\"[nospace-text $here]\" id=\"[nospace-text $here]\">$switch</a>"
}
proc std-option-toc {name page} {
global manual
if {[info exists manual(standard-option-$page-$name)]} {
lappend manual(section-toc) <dd>$manual(standard-option-$page-$name)
return $manual(standard-option-$page-$name)
}
manerror "missing reference to \"$name\" in $page.n"
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
set other M$name
lappend manual(section-toc) "<dd><a href=\"$page.html#$other\">$name</a>"
return "<a href=\"$page.html#$other\">$name</a>"
}
##
## process the widget option section
## in widget and options man pages
##
proc output-widget-options {rest} {
global manual
man-puts <dl>
lappend manual(section-toc) <dl>
backup-text 1
set para {}
while {[next-op-is .OP rest]} {
switch -exact -- [llength $rest] {
3 {
lassign $rest switch name class
}
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
}
if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
error "not Name: $name"
}
if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
error "not Class: $class"
}
| | | | | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 |
}
if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
error "not Name: $name"
}
if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
error "not Class: $class"
}
man-puts "$para<dt>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
man-puts "<dt>Database Name: $oname$name$cname"
man-puts "<dt>Database Class: $oclass$class$cclass"
man-puts <dd>[next-text]
set para <p>
if {[next-op-is .RS rest]} {
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact -- $code {
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
}
} else {
man-puts $line
}
}
}
}
| | | | | | | 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 |
}
} else {
man-puts $line
}
}
}
}
man-puts </dl>
lappend manual(section-toc) </dl>
}
##
## process .RS lists
##
proc output-RS-list {} {
global manual
if {[next-op-is .IP rest]} {
output-IP-list .RS .IP $rest
if {[match-text .RE .sp .RS @rest .IP @rest2]} {
man-puts <p>$rest
output-IP-list .RS .IP $rest2
}
if {[match-text .RE .sp .RS @rest .RE]} {
man-puts <p>$rest
return
}
if {[next-op-is .RE rest]} {
return
}
}
man-puts <dl><dd>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact -- $code {
.RE {
break
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
output-directive $line
}
}
} else {
man-puts $line
}
}
| | | | | | | | | | | | | | | | | | | | 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 |
output-directive $line
}
}
} else {
man-puts $line
}
}
man-puts </dl>
}
##
## process .IP lists which may be plain indents,
## numeric lists, or definition lists
##
proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
# blank label, plain indent, no contents entry
man-puts <dl><dd>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
if {$code eq ".IP" && $rest eq {}} {
man-puts "<p>"
continue
}
if {$code in {.br .DS .RS}} {
output-directive $line
} else {
backup-text 1
break
}
} else {
man-puts $line
}
}
man-puts </dl>
} else {
# labelled list, make contents
if {$context ne ".SH" && $context ne ".SS"} {
man-puts <p>
}
set dl "<dl class=\"[string tolower $manual(section)]\">"
set enddl "</dl>"
if {$code eq ".IP"} {
if {[regexp {^\[[\da-f]+\]|\(?[\da-f]+\)$} $rest]} {
set dl "<ol class=\"[string tolower $manual(section)]\">"
set enddl "</ol>"
} elseif {"•" eq $rest} {
set dl "<ul class=\"[string tolower $manual(section)]\">"
set enddl "</ul>"
}
}
man-puts $dl
lappend manual(section-toc) $dl
backup-text 1
set accept_RE 0
set para {}
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact -- $code {
.IP {
if {$accept_RE} {
output-IP-list .IP $code $rest
continue
}
if {$manual(section) eq "ARGUMENTS"} {
man-puts "$para<dt>$rest<dd>"
} elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} {
man-puts "$para<li value=\"$value\">"
} elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} {
man-puts "$para<li value=\"$value\">"
} elseif {"•" eq $rest} {
man-puts "$para<li>"
} else {
man-puts "$para<dt>[long-toc $rest]<dd>"
}
}
.sp - .br - .DS - .CS {
output-directive $line
}
.RS {
if {[match-text .RS]} {
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 |
} else {
output-directive $line
}
}
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
| | | | | | 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 |
} else {
output-directive $line
}
}
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
man-puts "$para<dt>[long-toc $rest1]"
man-puts "<dt>[long-toc $rest2]<dd>"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if {!$accept_RE} {
man-puts "$enddl<p>$rest$dl"
backup-text 1
set para {}
break
}
man-puts "<p>$rest"
incr accept_RE -1
} elseif {$accept_RE} {
output-directive $line
} else {
backup-text 1
break
}
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
backup-text 1
break
}
}
} else {
man-puts $line
}
| | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 |
backup-text 1
break
}
}
} else {
man-puts $line
}
set para <p>
}
man-puts "$para$enddl"
lappend manual(section-toc) $enddl
if {$accept_RE} {
manerror "missing .RE in output-IP-list"
}
}
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
proc output-name {line} {
global manual
# split name line into pieces
regexp {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] -> head tail
# output line to manual page untouched
man-puts "$head — $tail"
# output line to long table of contents
| | | | 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 |
proc output-name {line} {
global manual
# split name line into pieces
regexp {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] -> head tail
# output line to manual page untouched
man-puts "$head — $tail"
# output line to long table of contents
lappend manual(section-toc) "<dl><dd>$head — $tail</dd></dl>"
# separate out the names for future reference
foreach name [split $head ,] {
set name [string trim $name]
if {[llength $name] > 1} {
manerror "name has a space: {$name}\nfrom: $line"
}
lappend manual(wing-toc) $name
lappend manual(name-$name) $manual(wing-file)/$manual(name)
}
set manual(tooltip-$manual(wing-file)/$manual(name).html) $line
}
##
## build a cross-reference link if appropriate
##
proc cross-reference {ref} {
global manual remap_link_target
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
}
} elseif {$ref eq "Tcl"} {
set lref $ref
} elseif {
[regexp {^[A-Z0-9 ?!]+$} $ref]
&& [info exists manual($manname-id-$ref)]
} {
| | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
}
} elseif {$ref eq "Tcl"} {
set lref $ref
} elseif {
[regexp {^[A-Z0-9 ?!]+$} $ref]
&& [info exists manual($manname-id-$ref)]
} {
return "<a href=\"#$manual($manname-id-$ref)\">$ref</a>"
} else {
set lref [string tolower $ref]
##
## apply a link remapping if available
##
if {[info exists remap_link_target($lref)]} {
set lref $remap_link_target($lref)
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
if {
[regexp "^$name \[a-z0-9]*\$" $lref] &&
[info exists manual(name-$name)] &&
$mantail ne "$name.n" &&
(![info exists exclude_refs_map($mantail)] ||
$manual(name-$name) ni $exclude_refs_map($mantail))
} {
| | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
if {
[regexp "^$name \[a-z0-9]*\$" $lref] &&
[info exists manual(name-$name)] &&
$mantail ne "$name.n" &&
(![info exists exclude_refs_map($mantail)] ||
$manual(name-$name) ni $exclude_refs_map($mantail))
} {
return "<a href=\"../$manual(name-$name).html\">$ref</a>"
}
}
if {$lref in {end}} {
# no good place to send this tcl token?
}
return $ref
}
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
## multiple choices for reference
##
if {[llength $manref] > 1} {
set tcl_i [lsearch -glob $manref *TclCmd*]
if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
|| $manual(wing-file) eq "TclLib"} {
set tcl_ref [lindex $manref $tcl_i]
| | | | | 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 |
## multiple choices for reference
##
if {[llength $manref] > 1} {
set tcl_i [lsearch -glob $manref *TclCmd*]
if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
|| $manual(wing-file) eq "TclLib"} {
set tcl_ref [lindex $manref $tcl_i]
return "<a href=\"../$tcl_ref.html\">$ref</a>"
}
set tk_i [lsearch -glob $manref *TkCmd*]
if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd"
|| $manual(wing-file) eq "TkLib"} {
set tk_ref [lindex $manref $tk_i]
return "<a href=\"../$tk_ref.html\">$ref</a>"
}
if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} {
set tcl_ref [lindex $manref $tcl_i]
return "<a href=\"../$tcl_ref.html\">$ref</a>"
}
puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
return $ref
}
##
## exceptions, sigh, to the rule
##
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
&& $lref in $exclude_refs_map($mantail)
} {
return $ref
}
##
## return the cross reference
##
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
&& $lref in $exclude_refs_map($mantail)
} {
return $ref
}
##
## return the cross reference
##
return "<a href=\"../$manref.html\">$ref</a>"
}
##
## reference generation errors
##
proc reference-error {msg text} {
global manual
|
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
global manual
set result ""
while 1 {
##
## we identify cross references by:
## ``quotation''
| | | | | 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 |
global manual
set result ""
while 1 {
##
## we identify cross references by:
## ``quotation''
## <b>emboldening</b>
## Tcl_ prefix
## Tk_ prefix
## [a-zA-Z0-9]+ manual entry
## and we avoid messing with already anchored text
##
##
## find where each item lives - EXPENSIVE - and accumulate a list
##
unset -nocomplain offsets
foreach {name pattern} {
anchor {<a } end-anchor {</a>}
quote {``} end-quote {''}
bold {<b>} end-bold {</b>}
c.tcl {Tcl_}
c.tk {Tk_}
c.ttk {Ttk_}
c.tdbc {Tdbc_}
c.itcl {Itcl_}
Tcl1 {Tcl manual entry}
Tcl2 {Tcl overview manual entry}
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
url - end-bold {
append result \
[string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
| | | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 |
url - end-bold {
append result \
[string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
regsub {http://[\w/.-]+} $body {<a href="&">&</a>} body
append result <b> [cross-reference $body] </b>
continue
}
anchor {
append result \
[string range $text 0 [expr {$offset(end-bold)+3}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
regexp -indices -start $off {http://[\w/.-]+} $text range
set url [string range $text {*}$range]
| | | | | | | | | | | | | | | | 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 |
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
regexp -indices -start $off {http://[\w/.-]+} $text range
set url [string range $text {*}$range]
append result "<a href=\"[string trimright $url .]\">$url</a>"
set text [string range $text[set text ""] \
[expr {[lindex $range 1]+1}] end]
continue
}
end-anchor - end-bold - end-quote {
return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
}
}
}
}
##
## process formatting directives
##
proc output-directive {line} {
global manual
# process format directive
split-directive $line code rest
switch -exact -- $code {
.BS - .BE {
# man-puts <hr>
}
.SH - .SS {
# drain any open lists
# announce the subject
set manual(section) $rest
# start our own stack of stuff
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
if {$code ne ".SS"} {
man-puts "<h3>[long-toc $manual(section)]</h3>"
} else {
man-puts "<h4>[long-toc $manual(section)]</h4>"
}
# some sections can simply free wheel their way through the text
# some sections can be processed in their own loops
switch -exact -- [string index $code end]:$manual(section) {
H:NAME {
set names {}
while {1} {
set line [next-text]
if {[is-a-directive $line]} {
backup-text 1
if {[llength $names]} {
output-name [join $names { }]
}
return
}
lappend names [string trim $line]
}
}
H:SYNOPSIS {
lappend manual(section-toc) <dl>
while {1} {
if {
[next-op-is .nf rest]
|| [next-op-is .br rest]
|| [next-op-is .fi rest]
} {
continue
}
if {
[next-op-is .SH rest]
|| [next-op-is .SS rest]
|| [next-op-is .BE rest]
|| [next-op-is .SO rest]
} {
backup-text 1
break
}
if {[next-op-is .sp rest]} {
#man-puts <p>
continue
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "in SYNOPSIS found $more"
backup-text 1
break
}
foreach more [split $more \n] {
regexp {^(\s*)(.*)} $more -> spaces more
set spaces [string map {" " " "} $spaces]
if {[string length $spaces]} {
set spaces <tt>$spaces</tt>
}
man-puts $spaces$more<br>
if {$manual(wing-file) in {TclLib TkLib}} {
lappend manual(section-toc) <dd>$more
}
}
}
lappend manual(section-toc) </dl>
return
}
{H:SEE ALSO} {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
backup-text 1
return
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "$more"
backup-text 1
return
}
set nmore {}
foreach cr [split $more ,] {
set cr [string trim $cr]
if {![regexp {^<b>.*</b>$} $cr]} {
set cr <b>$cr</b>
}
if {[regexp {^<b>(.*)\([13n]\)</b>$} $cr all name]} {
set cr <b>$name</b>
}
lappend nmore $cr
}
man-puts [join $nmore {, }]
}
return
}
|
| ︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 |
backup-text 1
return
}
set keys {}
foreach key [split $more ,] {
set key [string trim $key]
lappend manual(keyword-$key) [list $manual(name) \
| | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
backup-text 1
return
}
set keys {}
foreach key [split $more ,] {
set key [string trim $key]
lappend manual(keyword-$key) [list $manual(name) \
$manual(wing-file)/$manual(name).html]
set initial [string toupper [string index $key 0]]
lappend keys "<a href=\"../Keywords/$initial.html\#$key\">$key</a>"
}
man-puts [join $keys {, }]
}
return
}
}
if {[next-op-is .IP rest]} {
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 |
manerror "unexpected .SO format:\n[expand-next-text 2]"
}
if {![next-op-is .SO rest]} {
break
}
}
output-directive {.SH STANDARD OPTIONS}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
manerror "unexpected .SO format:\n[expand-next-text 2]"
}
if {![next-op-is .SO rest]} {
break
}
}
output-directive {.SH STANDARD OPTIONS}
man-puts <dl>
lappend manual(section-toc) <dl>
foreach optionpair [lsort -dictionary -index 0 $optslist] {
lassign $optionpair option targetPage
man-puts "<dt><b>[std-option-toc $option $targetPage]</b>"
}
man-puts </dl>
lappend manual(section-toc) </dl>
}
.OP {
output-widget-options $rest
return
}
.IP {
output-IP-list .IP .IP $rest
return
}
.PP - .sp {
man-puts <p>
}
.RS {
output-RS-list
return
}
.br {
man-puts <br>
return
}
.DS {
if {[next-op-is .ta rest]} {
# skip the leading .ta directive if it is there
}
if {[match-text @stuff .DE]} {
set td "<td><p class=\"tablecell\">"
set bodyText [string map [list \n <tr>$td \t $td] \n$stuff]
man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>"
#man-puts <pre>$stuff</pre>
} elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
man-puts "<pre>[lindex $ul1 1][lindex $ul2 1]\n$stuff</pre>"
} else {
manerror "unexpected .DS format:\n[expand-next-text 2]"
}
return
}
.CS {
if {[next-op-is .ta rest]} {
# ???
}
if {[match-text @stuff .CE]} {
man-puts <pre>$stuff</pre>
} else {
manerror "unexpected .CS format:\n[expand-next-text 2]"
}
return
}
.nf {
if {[match-text @more .fi]} {
foreach more [split $more \n] {
man-puts $more<br>
}
} elseif {[match-text .RS @more .RE .fi]} {
man-puts <dl><dd>
foreach more [split $more \n] {
man-puts $more<br>
}
man-puts </dl>
} elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
man-puts <dl><dd>
foreach more [split $more \n] {
man-puts $more<br>
}
man-puts <dl><dd>
foreach more2 [split $more2 \n] {
man-puts $more2<br>
}
man-puts </dl></dl>
} elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
man-puts <dl><dd>
foreach more [split $more \n] {
man-puts $more<br>
}
man-puts <dl><dd>
foreach more2 [split $more2 \n] {
man-puts $more2<br>
}
man-puts </dl><dd>
foreach more3 [split $more3 \n] {
man-puts $more3<br>
}
man-puts </dl>
} elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
man-puts <p><dl><dd>
foreach more [split $more \n] {
man-puts $more<br>
}
man-puts <dl><dd>
foreach more2 [split $more2 \n] {
man-puts $more2<br>
}
man-puts </dl></dl><p>
} elseif {[match-text .RS .sp @more .sp .RE .fi]} {
man-puts <p><dl><dd>
foreach more [split $more \n] {
man-puts $more<br>
}
man-puts </dl><p>
} else {
manerror "ignoring $line"
}
}
.RE - .DE - .CE {
manerror "unexpected $code"
return
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
## sectionDescriptor, convert manpages into hypertext in
## the directory specified by outputDir.
##
proc make-manpage-section {outputDir sectionDescriptor} {
global manual overall_title tcltkdesc verbose
global excluded_pages forced_index_pages process_first_patterns
| | | | | | 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 |
## sectionDescriptor, convert manpages into hypertext in
## the directory specified by outputDir.
##
proc make-manpage-section {outputDir sectionDescriptor} {
global manual overall_title tcltkdesc verbose
global excluded_pages forced_index_pages process_first_patterns
set LQ \u201C
set RQ \u201D
lassign $sectionDescriptor \
manual(wing-glob) \
manual(wing-name) \
manual(wing-file) \
manual(wing-description)
set manual(wing-copyrights) {}
makedirhier $outputDir/$manual(wing-file)
set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w]
# whistle
puts stderr "scanning section $manual(wing-name)"
# put the entry for this section into the short table of contents
if {[regexp {^(.+), version (.+)$} $manual(wing-name) -> name version]} {
puts $manual(short-toc-fp) "<dt><a href=\"$manual(wing-file)/[indexfile]\" title=\"version $version\">$name</a></dt><dd>$manual(wing-description)</dd>"
} else {
puts $manual(short-toc-fp) "<dt><a href=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</a></dt><dd>$manual(wing-description)</dd>"
}
# initialize the wing table of contents
puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
$manual(wing-name) $overall_title "../[indexfile]"]
# initialize the short table of contents for this section
set manual(wing-toc) {}
# initialize the man directory for this section
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 | set manual(wing-copyrights) [merge-copyrights \ $manual(wing-copyrights) $manual(copyrights)] } # # make the long table of contents for this page # set manual(toc-$manual(wing-file)-$manual(name)) \ | | | 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 |
set manual(wing-copyrights) [merge-copyrights \
$manual(wing-copyrights) $manual(copyrights)]
}
#
# make the long table of contents for this page
#
set manual(toc-$manual(wing-file)-$manual(name)) \
[concat <dl> $manual(section-toc) </dl>]
}
if {!$verbose} {
puts stderr ""
}
if {![llength $manual(wing-toc)]} {
fatal "not table of contents."
|
| ︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 |
foreach name [lsort -dictionary $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
| | | | | | | 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 |
foreach name [lsort -dictionary $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
if {[info exists manual(tooltip-$manual(wing-file)/$tail.html)]} {
set tooltip $manual(tooltip-$manual(wing-file)/$tail.html)
set tooltip [string map {[ {\[} ] {\]} $ {\$} \\ \\\\} $tooltip]
regsub {^[^-]+-\s*(.)} $tooltip {[string totitle \1]} tooltip
append rows([expr {$n%$nrows}]) \
"<td> <a href=\"$tail.html\" title=\"[subst $tooltip]\">$name</a> </td>"
} else {
append rows([expr {$n%$nrows}]) \
"<td> <a href=\"$tail.html\">$name</a> </td>"
}
incr n
}
puts $manual(wing-toc-fp) <table>
foreach row [lsort -integer [array names rows]] {
puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
}
puts $manual(wing-toc-fp) </table>
#
# insert wing copyrights
#
puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"]
puts $manual(wing-toc-fp) "</body></html>"
close $manual(wing-toc-fp)
set manual(merge-copyrights) \
[merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
}
proc makedirhier {dir} {
try {
|
| ︙ | ︙ |
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\
tclsh8.6 (or the equivalent tclsh86.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.
#
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
proc css-style args {
upvar 1 style style
set body [uplevel 1 [list subst [lindex $args end]]]
set tokens [join [lrange $args 0 end-1] ", "]
append style $tokens " \{" $body "\}\n"
}
proc css-stylesheet {} {
| | | | | | | | | | | 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 |
proc css-style args {
upvar 1 style style
set body [uplevel 1 [list subst [lindex $args end]]]
set tokens [join [lrange $args 0 end-1] ", "]
append style $tokens " \{" $body "\}\n"
}
proc css-stylesheet {} {
set hBd "1px dotted #11577B"
css-style body div p th td li dd ul ol dl dt blockquote {
font-family: Verdana, sans-serif;
}
css-style pre code {
font-family: 'Courier New', Courier, monospace;
}
css-style pre {
background-color: #F6FCEC;
border-top: 1px solid #6A6A6A;
border-bottom: 1px solid #6A6A6A;
padding: 1em;
overflow: auto;
}
css-style body {
background-color: #FFFFFF;
font-size: 12px;
line-height: 1.25;
letter-spacing: .2px;
padding-left: .5em;
}
css-style h1 h2 h3 h4 {
font-family: Georgia, serif;
padding-left: 1em;
margin-top: 1em;
}
css-style h1 {
font-size: 18px;
color: #11577B;
border-bottom: $hBd;
margin-top: 0px;
}
css-style h2 {
font-size: 14px;
color: #11577B;
background-color: #C5DCE8;
padding-left: 1em;
border: 1px solid #6A6A6A;
}
css-style h3 h4 {
color: #1674A4;
background-color: #E8F2F6;
border-bottom: $hBd;
border-top: $hBd;
}
css-style h3 {
font-size: 12px;
}
css-style h4 {
font-size: 11px;
}
css-style ".keylist dt" ".arguments dt" {
width: 20em;
float: left;
padding: 2px;
border-top: 1px solid #999999;
}
css-style ".keylist dt" { font-weight: bold; }
css-style ".keylist dd" ".arguments dd" {
margin-left: 20em;
padding: 2px;
border-top: 1px solid #999999;
}
css-style .copy {
background-color: #F6FCFC;
white-space: pre;
font-size: 80%;
border-top: 1px solid #6A6A6A;
margin-top: 2em;
}
css-style .tablecell {
font-size: 12px;
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
makedirhier $html
set cssfd [open $html/$::CSSFILE w]
puts $cssfd [css-stylesheet]
close $cssfd
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/[indexfile] w]
puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title]
| | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
makedirhier $html
set cssfd [open $html/$::CSSFILE w]
puts $cssfd [css-stylesheet]
close $cssfd
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/[indexfile] w]
puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title]
puts $manual(short-toc-fp) "<dl class=\"keylist\">"
set manual(merge-copyrights) {}
foreach arg $args {
# preprocess to set up subheader for the rest of the files
if {![llength $arg]} {
continue
}
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
$overall_title "../[indexfile]"]
set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
# Create header first
set keyheader {}
foreach a $letters {
set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
if {[llength $keys]} {
| | | | | | | | | | | | | | | | | 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 |
$overall_title "../[indexfile]"]
set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
# Create header first
set keyheader {}
foreach a $letters {
set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
if {[llength $keys]} {
lappend keyheader "<a href=\"$a.html\">$a</a>"
} else {
# No keywords for this letter
lappend keyheader $a
}
}
set keyheader <h3>[join $keyheader " |\n"]</h3>
puts $keyfp $keyheader
foreach a $letters {
set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
if {![llength $keys]} {
continue
}
# Per-keyword page
set afp [open $html/Keywords/$a.html w]
puts $afp [htmlhead "$tcltkdesc Keywords - $a" \
"$tcltkdesc Keywords - $a" \
$overall_title "../[indexfile]"]
puts $afp $keyheader
puts $afp "<dl class=\"keylist\">"
foreach k [lsort -dictionary $keys] {
set k [string range $k 8 end]
puts $afp "<dt><a name=\"[nospace-text $k]\" id=\"[nospace-text $k]\">$k</a></dt>"
puts $afp "<dd>"
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
set file [lindex $man 1]
if {[info exists manual(tooltip-$file)]} {
set tooltip $manual(tooltip-$file)
if {[string match {*[<>""]*} $tooltip]} {
manerror "bad tooltip for $file: \"$tooltip\""
}
lappend refs "<a href=\"../$file\" title=\"$tooltip\">$name</a>"
} else {
lappend refs "<a href=\"../$file\">$name</a>"
}
}
puts $afp "[join $refs {, }]</dd>"
}
puts $afp "</dl>"
# insert merged copyrights
puts $afp [copyout $manual(merge-copyrights)]
puts $afp "</body></html>"
close $afp
}
# insert merged copyrights
puts $keyfp [copyout $manual(merge-copyrights)]
puts $keyfp "</body></html>"
close $keyfp
##
## finish off short table of contents
##
puts $manual(short-toc-fp) "<dt><a href=\"Keywords/[indexfile]\">Keywords</a><dd>The keywords from the $tcltkdesc man pages."
puts $manual(short-toc-fp) "</dl>"
# insert merged copyrights
puts $manual(short-toc-fp) [copyout $manual(merge-copyrights)]
puts $manual(short-toc-fp) "</body></html>"
close $manual(short-toc-fp)
##
## output man pages
##
unset manual(section)
if {!$verbose} {
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
incr ntoc
}
if {$verbose} {
puts stderr "rescanning page $manual(name) $ntoc/$ntext"
} else {
puts -nonewline stderr .
}
| | | | 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 |
incr ntoc
}
if {$verbose} {
puts stderr "rescanning page $manual(name) $ntoc/$ntext"
} else {
puts -nonewline stderr .
}
set outfd [open $html/$manual(wing-file)/$manual(name).html w]
puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \
$manual(name) $wing_name "[indexfile]" \
$overall_title "../[indexfile]"]
if {($ntext > 60) && ($ntoc > 32)} {
foreach item $toc {
puts $outfd $item
}
} elseif {$manual(name) in $forced_index_pages} {
if {!$verbose} {puts stderr ""}
manerror "forcing index generation"
foreach item $toc {
puts $outfd $item
}
}
foreach item $text {
puts $outfd [insert-cross-references $item]
}
puts $outfd "</body></html>"
} on error msg {
if {$verbose} {
puts stderr $msg
} else {
puts stderr "\nError when processing $manual(name): $msg"
}
} finally {
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 632 633 634 635 636 637 638 |
Tk_3DBorder Tk_Get3DBorder
Tk_Anchor Tk_GetAnchor
Tk_Cursor Tk_GetCursor
Tk_Dash Tk_GetDash
Tk_Font Tk_GetFont
Tk_Image Tk_GetImage
Tk_ImageMaster Tk_GetImage
Tk_ItemType Tk_CreateItemType
Tk_Justify Tk_GetJustify
Ttk_Theme Ttk_GetTheme
}
array set exclude_refs_map {
bind.n {button destroy option}
clock.n {next}
| > | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
Tk_3DBorder Tk_Get3DBorder
Tk_Anchor Tk_GetAnchor
Tk_Cursor Tk_GetCursor
Tk_Dash Tk_GetDash
Tk_Font Tk_GetFont
Tk_Image Tk_GetImage
Tk_ImageMaster Tk_GetImage
Tk_ImageModel Tk_GetImage
Tk_ItemType Tk_CreateItemType
Tk_Justify Tk_GetJustify
Ttk_Theme Ttk_GetTheme
}
array set exclude_refs_map {
bind.n {button destroy option}
clock.n {next}
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
if {2 != [llength $description]} {
regexp {([^0-9]*)(.*)} $dir -> n v
set description [list $n $v]
}
# ... but try to extract (name, version) from subdir contents
try {
| > > > | > | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
if {2 != [llength $description]} {
regexp {([^0-9]*)(.*)} $dir -> n v
set description [list $n $v]
}
# ... but try to extract (name, version) from subdir contents
try {
try {
set f [open [file join $pkgsDir $dir configure.in]]
} trap {POSIX ENOENT} {} {
set f [open [file join $pkgsDir $dir configure.ac]]
}
foreach line [split [read $f] \n] {
if {2 == [scan $line \
{ AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} {
set description [list $n $v]
break
}
}
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 |
#
# Invoke the scraper/converter engine.
#
make-man-pages $webdir \
[list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
"The interpreters which implement $cmdesc."] \
[plus-base $build_tcl $tcldir doc/*.n {Tcl Commands} TclCmd \
| | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
#
# Invoke the scraper/converter engine.
#
make-man-pages $webdir \
[list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
"The interpreters which implement $cmdesc."] \
[plus-base $build_tcl $tcldir doc/*.n {Tcl Commands} TclCmd \
"The commands which the <b>tclsh</b> interpreter implements."] \
[plus-base $build_tk $tkdir doc/*.n {Tk Commands} TkCmd \
"The additional commands which the <b>wish</b> interpreter implements."] \
{*}[plus-pkgs n {*}$packageBuildList] \
[plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \
"The C functions which a Tcl extended C program may use."] \
[plus-base $build_tk $tkdir doc/*.3 {Tk C API} TkLib \
"The additional C functions which a Tk extended C program may use."] \
{*}[plus-pkgs 3 {*}$packageBuildList]
} on error {msg opts} {
|
| ︙ | ︙ |
Changes to tools/uniClass.tcl.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
# in order for the class ranges to match.
#
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
| | | | | | | | | | | | 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 |
# in order for the class ranges to match.
#
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xFFFF} {
set extranges 1
set numranges 0
set ranges [string trimright $ranges " \n\r\t,"]
append ranges "\n#if CHRBITS > 16\n ,"
}
append ranges [format "{0x%X, 0x%X}, " \
$first $last]
if {[incr numranges] % 4 == 0} {
set ranges [string trimright $ranges]
append ranges "\n "
}
} else {
if {!$extchars && ($first) > 0xFFFF} {
set extchars 1
set numchars 0
set chars [string trimright $chars " \n\r\t,"]
append chars "\n#if CHRBITS > 16\n ,"
}
append chars [format "0x%X, " $first]
incr numchars
if {$numchars % 9 == 0} {
set chars [string trimright $chars]
append chars "\n "
}
if {$first != $last} {
append chars [format "0x%X, " $last]
incr numchars
if {$numchars % 9 == 0} {
append chars "\n "
}
}
}
}
proc genTable {type} {
global first last ranges numranges chars numchars extchars extranges
set first -2
set last -2
set ranges " "
set numranges 0
set chars " "
set numchars 0
set extchars 0
set extranges 0
for {set i 0} {$i <= 0x10FFFF} {incr i} {
if {$i == 0xD800} {
# Skip surrogates
set i 0xE000
}
if {[string is $type [format %c $i]]} {
if {$i == ($last + 1)} {
set last $i
} else {
if {$first >= 0} {
emitRange $first $last
}
|
| ︙ | ︙ |
Changes to tools/uniParse.tcl.
1 2 3 4 5 6 7 8 | # uniParse.tcl -- # # This program parses the UnicodeData file and generates the # corresponding tclUniData.c file with compressed character # data tables. The input to this program should be the latest # UnicodeData file from: # ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# uniParse.tcl --
#
# This program parses the UnicodeData file and generates the
# corresponding tclUniData.c file with compressed character
# data tables. The input to this program should be the latest
# UnicodeData file from:
# ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt
#
# Copyright (c) 1998-1999 Scriptics Corporation.
# All rights reserved.
namespace eval uni {
set shift 5; # number of bits of data within a page
# This value can be adjusted to find the
# best split to minimize table size
|
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
return [list $categoryIndex $toupper $tolower $totitle]
}
proc uni::getGroup {value} {
variable groups
set gIndex [lsearch -exact $groups $value]
| | | | 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 |
return [list $categoryIndex $toupper $tolower $totitle]
}
proc uni::getGroup {value} {
variable groups
set gIndex [lsearch -exact $groups $value]
if {$gIndex < 0} {
set gIndex [llength $groups]
lappend groups $value
}
return $gIndex
}
proc uni::addPage {info} {
variable pMap
variable pages
variable shift
set pIndex [lsearch -exact $pages $info]
if {$pIndex < 0} {
set pIndex [llength $pages]
lappend pages $info
}
lappend pMap [expr {$pIndex << $shift}]
return
}
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
set line [format %X [expr {($next-1)|$mask}]]
append line ";;Cn;0;ON;;;;;N;;;;;\n"
}
set items [split $line \;]
scan [lindex $items 0] %x index
| | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
set line [format %X [expr {($next-1)|$mask}]]
append line ";;Cn;0;ON;;;;;N;;;;;\n"
}
set items [split $line \;]
scan [lindex $items 0] %x index
if {$index > 0x3FFFF} then {
# Ignore characters > plane 3
continue
}
set index [format %d $index]
set gIndex [getGroup [getValue $items $index]]
# Since the input table omits unassigned characters, these will
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 |
buildTables $data
puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]"
set size [expr {[llength $pMap]*2 + ([llength $pages]<<$shift)}]
puts "shift = $shift, space = $size"
set f [open [file join [lindex $argv 1] tclUniData.c] w]
| | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
buildTables $data
puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]"
set size [expr {[llength $pMap]*2 + ([llength $pages]<<$shift)}]
puts "shift = $shift, space = $size"
set f [open [file join [lindex $argv 1] tclUniData.c] w]
fconfigure $f -translation lf -encoding utf-8
puts $f "/*
* tclUniData.c --
*
* Declarations of Unicode character information tables. This file is
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
* Copyright (c) 1998 Scriptics Corporation.
* All rights reserved.
*/
/*
* A 16-bit Unicode character is split into two parts in order to index
* into the following tables. The lower OFFSET_BITS comprise an offset
* into a page of characters. The upper bits comprise the page number.
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
| | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= [format 0x%X $next])
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ | | | | | | 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 |
/*
* The following macros extract the fields of the character info. The
* GetDelta() macro is complicated because we can't rely on the C compiler
* to do sign extension on right shifts.
*/
#define GetCaseType(info) (((info) & 0xE0) >> 5)
#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F)
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#else
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#endif
"
close $f
}
uni::main
return
|
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: | > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ | < < < < < | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # If you use the setenv, putenv, or unsetenv procedures to modify environment # variables in your application and you'd like those modifications to appear # in the "env" Tcl variable, switch the comments on the two lines below so # that Tcl provides these procedures instead of your standard C library. ENV_FLAGS = #ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv |
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
| | | | 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 |
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \
@EXTRA_CC_SWITCHES@
CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 | INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ | | > | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-strip:
$(MAKE) $(INSTALL_TARGETS) \
INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \
"$(CONFIG_INSTALL_DIR)" ; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
|
| ︙ | ︙ | |||
985 986 987 988 989 990 991 | "$(CONFIG_INSTALL_DIR)/tclooConfig.sh" @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" | | | < < | > | | | > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"
@if test "$(STUB_LIB_FILE)" != "" ; then \
echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
@INSTALL_STUB_LIB@ ; \
fi
@EXTRA_INSTALL_BINARIES@
@echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/"
@$(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/pkgconfig"
@$(INSTALL_DATA) tcl.pc "$(LIB_INSTALL_DIR)/pkgconfig/tcl.pc"
install-libraries-zipfs-shared: libraries
@for i in "$(SCRIPT_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@for i in opt0.4 cookiejar0.2 encoding; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(MODULE_INSTALL_DIR)/$$i"; \
fi; \
done
@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; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@for i in $(TOP_DIR)/library/cookiejar/*.gz; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@echo "Installing package http 2.10.0a1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
"$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.tm"
@echo "Installing package opt 0.4.7"
@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)/8.7/msgcat-1.7.1.tm"
@echo "Installing package tcltest 2.5.3 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
"$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"
@echo "Installing package platform 1.0.15 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)/8.4/platform-1.0.15.tm"
@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
"$(MODULE_INSTALL_DIR)/8.4/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 {$(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"; \
fi; \
done
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
@for i in $(TOP_DIR)/library/tzdata/*; do \
if [ -d $$i ] ; then \
ii=`basename $$i`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
for j in $$i/*; do \
if [ -d $$j ] ; then \
jj=`basename $$j`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
fi; \
for k in $$j/*; do \
$(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
done; \
else \
$(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
done; \
else \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/tzdata"; \
fi; \
done
install-msgs:
@for i in msgs; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"
@for i in $(TOP_DIR)/library/msgs/*.msg; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \
done
install-doc: doc
@for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 | tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c |
| ︙ | ︙ | |||
2199 2200 2201 2202 2203 2204 2205 | mkdir -p RPMS/$$platform && \ rpmbuild -bb THIS.TCL.SPEC && \ mv RPMS/$$platform/*.rpm .; \ done -rm -rf RPMS THIS.TCL.SPEC # | | | | > > > > | | > | | | | 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 |
mkdir -p RPMS/$$platform && \
rpmbuild -bb THIS.TCL.SPEC && \
mv RPMS/$$platform/*.rpm .; \
done
-rm -rf RPMS THIS.TCL.SPEC
#
# Target to create a proper Tcl distribution from information in the
# source directory. DISTDIR must be defined to indicate where to put
# the distribution. DISTDIR must be an absolute path name.
#
DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat reg dde tcltest platform
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \
$(UNIX_DIR)/aclocal.m4
cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
cd $(MAC_OSX_DIR); autoheader; touch $@
$(TOP_DIR)/manifest.uuid:
printf "git." >$(TOP_DIR)/manifest.uuid
git rev-parse HEAD >>$(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)
mkdir -p $(DISTDIR)/unix
cp -p $(TOP_DIR)/manifest.uuid $(DISTDIR)
cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
cp -p $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
cp -p $(UNIX_DIR)/configure $(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)/ldAix $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
chmod 775 $(DISTDIR)/unix/configure
chmod 775 $(DISTDIR)/unix/ldAix
@mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \
|
| ︙ | ︙ | |||
2275 2276 2277 2278 2279 2280 2281 2282 | | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests @mkdir $(DISTDIR)/win | > > > > > > > > > > > > > | | < | 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 | | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests @mkdir $(DISTDIR)/tests/auto0 for i in auto1 auto2 ; \ do \ mkdir $(DISTDIR)/tests/auto0/$$i ;\ cp -p $(TOP_DIR)/tests/auto0/$$i/tclIndex $(TOP_DIR)/tests/auto0/$$i/*.tcl \ $(DISTDIR)/tests/auto0/$$i; \ done; for i in modules modules/mod1 modules/mod2 ; \ do \ mkdir $(DISTDIR)/tests/auto0/$$i ;\ cp -p $(TOP_DIR)/tests/auto0/$$i/*.tm \ $(DISTDIR)/tests/auto0/$$i; \ done; @mkdir $(DISTDIR)/win cp -p $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp -p $(TOP_DIR)/win/configure.ac $(TOP_DIR)/win/configure \ $(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 \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.vc $(DISTDIR)/win cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win @mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ |
| ︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 | cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest @mkdir $(DISTDIR)/tools | | < | < | | | > > > | 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 | cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest @mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/README $(TOOL_DIR)/*.c $(TOOL_DIR)/*.svg \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/*.bmp \ $(TOOL_DIR)/valgrind_suppress $(DISTDIR)/tools @mkdir $(DISTDIR)/libtommath cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath @mkdir $(DISTDIR)/pkgs cp -p $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs cp -p $(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 cp -p $(TOP_DIR)/.travis.yml $(DISTDIR) mkdir -p $(DISTDIR)/.github/workflows cp -p $(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); \ gzip -9 $(DISTNAME)-src.tar; \ zip -qr8 $(ZIPNAME) $(DISTNAME) ) |
| ︙ | ︙ |
Changes to unix/README.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | --enable-man-compression=PROG Compress the manpages using PROG. --enable-dtrace Enable tcl DTrace provider (if DTrace is available on the platform), c.f. tclDTrace.d for descriptions of the probes made available, see http://wiki.tcl.tk/DTrace for more details --with-encoding=ENCODING Specifies the encoding for compile-time | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
--enable-man-compression=PROG
Compress the manpages using PROG.
--enable-dtrace Enable tcl DTrace provider (if DTrace is
available on the platform), c.f. tclDTrace.d
for descriptions of the probes made available,
see http://wiki.tcl.tk/DTrace for more details
--with-encoding=ENCODING Specifies the encoding for compile-time
configuration values. Defaults to utf-8,
which is also sufficient for ASCII.
--with-tzdata=FLAG Specifies whether to install timezone data. By
default, the configure script tries to detect
whether a usable timezone database is present
on the system already.
Mac OS X only (i.e. completely unsupported on other platforms):
|
| ︙ | ︙ |
Changes to unix/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | | > | > | > > > > > > > > < < < < < < < < | | < | | < < < < < < | < < < < < < < | > > | < < > | | > > > > > > > > > | > > > > | < < < < < < < > | > > > | | < < < < < < < < < < < < < < < < < < < < | 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 |
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.70 for tcl 8.7.
#
#
# Copyright (C) 1992-1996, 1998-2017, 2020 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## -------------------- ##
## M4sh Initialization. ##
## -------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
as_nop=:
if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else $as_nop
case `(set -o) 2>/dev/null` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
# Reset variables that may have inherited troublesome values from
# the environment.
# IFS needs to be set, to space, tab, and newline, in precisely that order.
# (If _AS_PATH_WALK were called with IFS unset, it would have the
# side effect of setting IFS to empty, thus disabling word splitting.)
# Quoting is to prevent editors from complaining about space-tab.
as_nl='
'
export as_nl
IFS=" "" $as_nl"
PS1='$ '
PS2='> '
PS4='+ '
# Ensure predictable behavior from utilities with locale-dependent output.
LC_ALL=C
export LC_ALL
LANGUAGE=C
export LANGUAGE
# We cannot yet rely on "unset" to work, but we need these variables
# to be unset--not just set to an empty or harmless value--now, to
# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
# also avoids known problems related to "unset" and subshell syntax
# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
do eval test \${$as_var+y} \
&& ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
done
# Ensure that fds 0, 1, and 2 are open.
if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
# The user is always right.
if ${PATH_SEPARATOR+false} :; then
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
(PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
PATH_SEPARATOR=';'
}
fi
# Find who we are. Look in the path if we contain no directory separator.
as_myself=
case $0 in #((
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
test -r "$as_dir$0" && as_myself=$as_dir$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
exit 1
fi
# Use a proper internal environment variable to ensure we don't fall
# into an infinite loop, continuously re-executing ourselves.
if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
_as_can_reexec=no; export _as_can_reexec;
# We cannot yet assume a decent shell, so we have to provide a
# neutralization value for shells without unset; and this also
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
| | | | > > | | > | > > | > | | > | > | > > > | | > | > > > > > > | | > | < > | > | | > | | | | | | | 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 |
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
exit 255
fi
# We don't want this to propagate to other subprocesses.
{ _as_can_reexec=; unset _as_can_reexec;}
if test "x$CONFIG_SHELL" = x; then
as_bourne_compatible="as_nop=:
if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
# is contrary to our usage. Disable this feature.
alias -g '\${1+\"\$@\"}'='\"\$@\"'
setopt NO_GLOB_SUBST
else \$as_nop
case \`(set -o) 2>/dev/null\` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
"
as_required="as_fn_return () { (exit \$1); }
as_fn_success () { as_fn_return 0; }
as_fn_failure () { as_fn_return 1; }
as_fn_ret_success () { return 0; }
as_fn_ret_failure () { return 1; }
exitcode=0
as_fn_success || { exitcode=1; echo as_fn_success failed.; }
as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
if ( set x; as_fn_ret_success y && test x = \"\$1\" )
then :
else \$as_nop
exitcode=1; echo positional parameters were not saved.
fi
test x\$exitcode = x0 || exit 1
blah=\$(echo \$(echo blah))
test x\"\$blah\" = xblah || exit 1
test -x / || exit 1"
as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
test \$(( 1 + 1 )) = 2 || exit 1"
if (eval "$as_required") 2>/dev/null
then :
as_have_required=yes
else $as_nop
as_have_required=no
fi
if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null
then :
else $as_nop
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
as_found=false
for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
as_found=:
case $as_dir in #(
/*)
for as_base in sh bash ksh sh5; do
# Try only shells that exist, to save several forks.
as_shell=$as_dir$as_base
if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null
then :
CONFIG_SHELL=$as_shell as_have_required=yes
if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null
then :
break 2
fi
fi
done;;
esac
as_found=false
done
IFS=$as_save_IFS
if $as_found
then :
else $as_nop
if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null
then :
CONFIG_SHELL=$SHELL as_have_required=yes
fi
fi
if test "x$CONFIG_SHELL" != x
then :
export CONFIG_SHELL
# We cannot yet assume a decent shell, so we have to provide a
# neutralization value for shells without unset; and this also
# works around shells that cannot unset nonexistent variables.
# Preserve -v and -x to the replacement shell.
BASH_ENV=/dev/null
ENV=/dev/null
(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
case $- in # ((((
*v*x* | *x*v* ) as_opts=-vx ;;
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
exit 255
fi
if test x$as_have_required = xno
then :
printf "%s\n" "$0: This script requires a shell more modern than all"
printf "%s\n" "$0: the shells that I found on your system."
if test ${ZSH_VERSION+y} ; then
printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"
printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."
else
printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system,
$0: including any error possibly output before this
$0: message. Then install a modern shell, or manually run
$0: the script under such a shell if you do have one."
fi
exit 1
fi
fi
|
| ︙ | ︙ | |||
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 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
return $1
} # as_fn_set_status
# as_fn_exit STATUS
# -----------------
# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
as_fn_exit ()
{
set +e
as_fn_set_status $1
exit $1
} # as_fn_exit
# as_fn_mkdir_p
# -------------
# Create "$as_dir" as a directory, including parents if necessary.
as_fn_mkdir_p ()
{
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
| > > > > > > > > > | | | 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 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
return $1
} # as_fn_set_status
# as_fn_exit STATUS
# -----------------
# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
as_fn_exit ()
{
set +e
as_fn_set_status $1
exit $1
} # as_fn_exit
# as_fn_nop
# ---------
# Do nothing but, unlike ":", preserve the value of $?.
as_fn_nop ()
{
return $?
}
as_nop=as_fn_nop
# as_fn_mkdir_p
# -------------
# Create "$as_dir" as a directory, including parents if necessary.
as_fn_mkdir_p ()
{
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. | | > | | > | > > > > > > > > | | | 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 |
} # as_fn_executable_p
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
then :
eval 'as_fn_append ()
{
eval $1+=\$2
}'
else $as_nop
as_fn_append ()
{
eval $1=\$$1\$2
}
fi # as_fn_append
# as_fn_arith ARG...
# ------------------
# Perform arithmetic evaluation on the ARGs, and store the result in the
# global $as_val. Take advantage of shells that can avoid forks. The arguments
# must be portable across $(()) and expr.
if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
then :
eval 'as_fn_arith ()
{
as_val=$(( $* ))
}'
else $as_nop
as_fn_arith ()
{
as_val=`expr "$@" || test $? -eq 1`
}
fi # as_fn_arith
# as_fn_nop
# ---------
# Do nothing but, unlike ":", preserve the value of $?.
as_fn_nop ()
{
return $?
}
as_nop=as_fn_nop
# as_fn_error STATUS ERROR [LINENO LOG_FD]
# ----------------------------------------
# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
# script with STATUS, using 1 if that was 0.
as_fn_error ()
{
as_status=$1; test $as_status -eq 0 && as_status=1
if test "$4"; then
as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
printf "%s\n" "$as_me: error: $2" >&2
as_fn_exit $as_status
} # as_fn_error
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || | | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
as_dirname=false
fi
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
| | > > > > > > > > > > > | 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 |
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
{ printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
# If we had to re-execute with $CONFIG_SHELL, we're ensured to have
# already done that, so ensure we don't try to do so again and fall
# in an infinite loop. This has already happened in practice.
_as_can_reexec=no; export _as_can_reexec
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
# Determine whether it's possible to make 'echo' print without a newline.
# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
# for compatibility with existing Makefiles.
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
# For backward compatibility with old third-party macros, we provide
# the shell variables $as_echo and $as_echo_n. New code should use
# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
as_echo='printf %s\n'
as_echo_n='printf %s'
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 | PACKAGE_VERSION='8.7' PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ | | | | | < < < < < < < < < < < < < < > > > > > > > > > > | 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 | PACKAGE_VERSION='8.7' PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include <stddef.h> #ifdef HAVE_STDIO_H # include <stdio.h> #endif #ifdef HAVE_STDLIB_H # include <stdlib.h> #endif #ifdef HAVE_STRING_H # include <string.h> #endif #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #ifdef HAVE_STDINT_H # include <stdint.h> #endif #ifdef HAVE_STRINGS_H # include <strings.h> #endif #ifdef HAVE_SYS_TYPES_H # include <sys/types.h> #endif #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #endif #ifdef HAVE_UNISTD_H # include <unistd.h> #endif" ac_header_c_list= ac_subst_vars='DLTEST_SUFFIX DLTEST_LD EXTRA_TCLSH_LIBS EXTRA_BUILD_HTML EXTRA_INSTALL_BINARIES EXTRA_INSTALL EXTRA_APP_CC_SWITCHES |
| ︙ | ︙ | |||
739 740 741 742 743 744 745 746 747 748 749 750 751 752 | pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir | > | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir |
| ︙ | ︙ | |||
828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
infodir='${datarootdir}/info'
htmldir='${docdir}'
dvidir='${docdir}'
pdfdir='${docdir}'
| > | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
infodir='${datarootdir}/info'
htmldir='${docdir}'
dvidir='${docdir}'
pdfdir='${docdir}'
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 | case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac | < < | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
case $ac_option in
*=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
*=) ac_optarg= ;;
*) ac_optarg=yes ;;
esac
case $ac_dashdash$ac_option in
--)
ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
|
| ︙ | ︙ | |||
899 900 901 902 903 904 905 |
| --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
datarootdir=$ac_optarg ;;
-disable-* | --disable-*)
ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
| --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
datarootdir=$ac_optarg ;;
-disable-* | --disable-*)
ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid feature name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"enable_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
-dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
dvidir=$ac_optarg ;;
-enable-* | --enable-*)
ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
-dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
dvidir=$ac_optarg ;;
-enable-* | --enable-*)
ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid feature name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"enable_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 |
ac_prev=psdir ;;
-psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
psdir=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir=$ac_optarg ;;
| > > > > > > > > > | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
ac_prev=psdir ;;
-psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
psdir=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-runstatedir | --runstatedir | --runstatedi | --runstated \
| --runstate | --runstat | --runsta | --runst | --runs \
| --run | --ru | --r)
ac_prev=runstatedir ;;
-runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
| --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
| --run=* | --ru=* | --r=*)
runstatedir=$ac_optarg ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir=$ac_optarg ;;
|
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | | | 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 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid package name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"with_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
eval with_$ac_useropt=\$ac_optarg ;;
-without-* | --without-*)
ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid package name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"with_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
esac
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
| | | | | | 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 |
as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
esac
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2
expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2
: "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
done
if test -n "$ac_prev"; then
ac_option=--`echo $ac_prev | sed 's/_/-/g'`
as_fn_error $? "missing argument to $ac_option"
fi
if test -n "$ac_unrecognized_opts"; then
case $enable_option_checking in
no) ;;
fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
*) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
esac
fi
# Check all directory arguments for consistency.
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
datadir sysconfdir sharedstatedir localstatedir includedir \
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
libdir localedir mandir runstatedir
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
case $ac_val in
*/ )
ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
eval $ac_var=\$ac_val;;
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 | ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || | | | 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 |
ac_srcdir_defaulted=yes
# Try the directory containing this script, then the parent directory.
ac_confdir=`$as_dirname -- "$as_myself" ||
$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_myself" : 'X\(//\)[^/]' \| \
X"$as_myself" : 'X\(//\)$' \| \
X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_myself" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] | > | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 | Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] |
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 |
--enable-zipfs build with Zipfs support (default: on)
--enable-framework package shared libraries in MacOSX frameworks
(default: off)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
| | < | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
--enable-zipfs build with Zipfs support (default: on)
--enable-framework package shared libraries in MacOSX frameworks
(default: off)
Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
--with-encoding encoding for configuration values (default: utf-8)
--with-system-libtommath
use external libtommath (default: true if available,
false otherwise)
--with-tzdata install timezone data (default: autodetect)
Some influential environment variables:
CC C compiler command
|
| ︙ | ︙ | |||
1461 1462 1463 1464 1465 1466 1467 |
{ cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
| | | | 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
{ cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
case $ac_top_builddir_sub in
"") ac_top_builddir_sub=. ac_top_build_prefix= ;;
*) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
esac ;;
esac
ac_abs_top_builddir=$ac_pwd
ac_abs_builddir=$ac_pwd$ac_dir_suffix
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
cd "$ac_dir" || { ac_status=$?; continue; }
| | > | | | | | | | > | | | | | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > | | | | < < < | < < < < | | > | | | | > | | | > | | | > > | | > | | > | | | | > | | | | | > | | > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | | | > | | | > | | | | | > > > > > > > > > > > > > > > > > > > > | | | 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 |
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
cd "$ac_dir" || { ac_status=$?; continue; }
# Check for configure.gnu first; this name is used for a wrapper for
# Metaconfig's "Configure" on case-insensitive file systems.
if test -f "$ac_srcdir/configure.gnu"; then
echo &&
$SHELL "$ac_srcdir/configure.gnu" --help=recursive
elif test -f "$ac_srcdir/configure"; then
echo &&
$SHELL "$ac_srcdir/configure" --help=recursive
else
printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2
fi || ac_status=$?
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
tcl configure 8.7
generated by GNU Autoconf 2.70
Copyright (C) 2020 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
exit
fi
## ------------------------ ##
## Autoconf initialization. ##
## ------------------------ ##
# ac_fn_c_try_compile LINENO
# --------------------------
# Try to compile conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_compile ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
rm -f conftest.$ac_objext conftest.beam
if { { ac_try="$ac_compile"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compile") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest.$ac_objext
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_compile
# ac_fn_c_try_link LINENO
# -----------------------
# Try to link conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_link ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest$ac_exeext && {
test "$cross_compiling" = yes ||
test -x conftest$ac_exeext
}
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
# Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
# created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
# interfere with the next link command; also delete a directory that is
# left behind by Apple's compiler. We do this before executing the actions.
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_link
# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
# -------------------------------------------------------
# Tests whether HEADER exists and can be compiled using the include files in
# INCLUDES, setting the cache variable VAR accordingly.
ac_fn_c_check_header_compile ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
printf %s "checking for $2... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
#include <$2>
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
eval "$3=yes"
else $as_nop
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_header_compile
# ac_fn_c_try_cpp LINENO
# ----------------------
# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_cpp ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
if { { ac_try="$ac_cpp conftest.$ac_ext"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } > conftest.i && {
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
test ! -s conftest.err
}
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_cpp
# ac_fn_c_check_func LINENO FUNC VAR
# ----------------------------------
# Tests whether FUNC exists, setting the cache variable VAR accordingly
ac_fn_c_check_func ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
printf %s "checking for $2... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Define $2 to an innocuous variant, in case <limits.h> declares $2.
For example, HP-UX 11i <limits.h> declares gettimeofday. */
#define $2 innocuous_$2
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $2 (); below. */
#include <limits.h>
#undef $2
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char $2 ();
/* The GNU C library defines this for functions which it implements
to always fail with ENOSYS. Some functions are actually named
something starting with __ and the normal name is an alias. */
#if defined __stub_$2 || defined __stub___$2
choke me
#endif
int
main (void)
{
return $2 ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
eval "$3=yes"
else $as_nop
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_func
# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES
# ---------------------------------------------
# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
# accordingly.
ac_fn_c_check_decl ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
# Initialize each $ac_[]_AC_LANG_ABBREV[]_decl_warn_flag once.
as_decl_name=`echo $2|sed 's/ *(.*//'`
as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
printf %s "checking whether $as_decl_name is declared... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_save_werror_flag=$ac_c_werror_flag
ac_c_werror_flag="$ac_c_decl_warn_flag$ac_c_werror_flag"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main (void)
{
#ifndef $as_decl_name
#ifdef __cplusplus
(void) $as_decl_use;
#else
(void) $as_decl_name;
#endif
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
eval "$3=yes"
else $as_nop
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_c_werror_flag=$ac_save_werror_flag
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_decl
# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
# -------------------------------------------
# Tests whether TYPE exists after having included INCLUDES, setting cache
# variable VAR accordingly.
ac_fn_c_check_type ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
printf %s "checking for $2... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
eval "$3=no"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main (void)
{
if (sizeof ($2))
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main (void)
{
if (sizeof (($2)))
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
else $as_nop
eval "$3=yes"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_type
# ac_fn_c_try_run LINENO
# ----------------------
# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that
# executables *can* be run.
ac_fn_c_try_run ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
{ { case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_try") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }; }
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: program exited with status $ac_status" >&5
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=$ac_status
fi
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_run
# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES
# ----------------------------------------------------
# Tries to find if the field MEMBER exists in type AGGR, after including
# INCLUDES, setting cache variable VAR accordingly.
ac_fn_c_check_member ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5
printf %s "checking for $2.$3... " >&6; }
if eval test \${$4+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$5
int
main (void)
{
static $2 ac_aggr;
if (ac_aggr.$3)
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
eval "$4=yes"
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$5
int
main (void)
{
static $2 ac_aggr;
if (sizeof ac_aggr.$3)
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
eval "$4=yes"
else $as_nop
eval "$4=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
eval ac_res=\$$4
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_member
ac_configure_args_raw=
for ac_arg
do
case $ac_arg in
*\'*)
ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
as_fn_append ac_configure_args_raw " '$ac_arg'"
done
case $ac_configure_args_raw in
*$as_nl*)
ac_safe_unquote= ;;
*)
ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab.
ac_unsafe_a="$ac_unsafe_z#~"
ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"
ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;
esac
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by tcl $as_me 8.7, which was
generated by GNU Autoconf 2.70. Invocation command line was
$ $0$ac_configure_args_raw
_ACEOF
exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
## Platform. ##
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 | _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS | > | > > > | | 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 |
_ASUNAME
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
printf "%s\n" "PATH: $as_dir"
done
IFS=$as_save_IFS
} >&5
cat >&5 <<_ACEOF
|
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 |
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
| | | 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 |
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
2)
as_fn_append ac_configure_args1 " '$ac_arg'"
if test $ac_must_keep_next = true; then
ac_must_keep_next=false # Got value, back to normal.
|
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 |
# When interrupted or exit'd, cleanup temporary files, and complete
# config.log. We remove comments because anyway the quotes in there
# would cause problems or look ugly.
# WARNING: Use '\'' to represent an apostrophe within the trap.
# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
# Save into config.log some information that might help in debugging.
{
echo
| > > | | | | 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 |
# When interrupted or exit'd, cleanup temporary files, and complete
# config.log. We remove comments because anyway the quotes in there
# would cause problems or look ugly.
# WARNING: Use '\'' to represent an apostrophe within the trap.
# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
# Sanitize IFS.
IFS=" "" $as_nl"
# Save into config.log some information that might help in debugging.
{
echo
printf "%s\n" "## ---------------- ##
## Cache variables. ##
## ---------------- ##"
echo
# The following way of writing the cache mishandles newlines in values,
(
for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
*) { eval $ac_var=; unset $ac_var;} ;;
esac ;;
esac
|
| ︙ | ︙ | |||
2177 2178 2179 2180 2181 2182 2183 |
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
| | | | | | | | | | | < | < < | < < | < < | < < | < < | < < < < | < < < < | < | < > | | > > > > > | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | > | | 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 |
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
printf "%s\n" "## ----------------- ##
## Output variables. ##
## ----------------- ##"
echo
for ac_var in $ac_subst_vars
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
printf "%s\n" "## ------------------- ##
## File substitutions. ##
## ------------------- ##"
echo
for ac_var in $ac_subst_files
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
printf "%s\n" "## ----------- ##
## confdefs.h. ##
## ----------- ##"
echo
cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
printf "%s\n" "$as_me: caught signal $ac_signal"
printf "%s\n" "$as_me: exit $exit_status"
} >&5
rm -f core *.core core.conftest.* &&
rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
' 0
for ac_signal in 1 2 13 15; do
trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal
done
ac_signal=0
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -f -r conftest* confdefs.h
printf "%s\n" "/* confdefs.h */" > confdefs.h
# Predefined preprocessor variables.
printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h
# Let the site file select an alternate cache file if it wants to.
# Prefer an explicitly selected file to automatically selected ones.
if test -n "$CONFIG_SITE"; then
ac_site_files="$CONFIG_SITE"
elif test "x$prefix" != xNONE; then
ac_site_files="$prefix/share/config.site $prefix/etc/config.site"
else
ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
fi
for ac_site_file in $ac_site_files
do
case $ac_site_file in #(
*/*) :
;; #(
*) :
ac_site_file=./$ac_site_file ;;
esac
if test -f "$ac_site_file" && test -r "$ac_site_file"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
. "$ac_site_file" \
|| { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "failed to load site script $ac_site_file
See \`config.log' for more details" "$LINENO" 5; }
fi
done
if test -r "$cache_file"; then
# Some versions of bash will fail to source /dev/null (special files
# actually), so we avoid doing that. DJGPP emulates it as a regular file.
if test /dev/null != "$cache_file" && test -f "$cache_file"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
printf "%s\n" "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
[\\/]* | ?:[\\/]* ) . "$cache_file";;
*) . "./$cache_file";;
esac
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
printf "%s\n" "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
# Test code for whether the C compiler supports C89 (global declarations)
ac_c_conftest_c89_globals='
/* Does the compiler advertise C89 conformance?
Do not test the value of __STDC__, because some compilers set it to 0
while being otherwise adequately conformant. */
#if !defined __STDC__
# error "Compiler does not advertise C89 conformance"
#endif
#include <stddef.h>
#include <stdarg.h>
struct stat;
/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */
struct buf { int x; };
struct buf * (*rcsopen) (struct buf *, struct stat *, int);
static char *e (p, i)
char **p;
int i;
{
return p[i];
}
static char *f (char * (*g) (char **, int), char **p, ...)
{
char *s;
va_list v;
va_start (v,p);
s = g (p, va_arg (v,int));
va_end (v);
return s;
}
/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
function prototypes and stuff, but not \xHH hex character constants.
These do not provoke an error unfortunately, instead are silently treated
as an "x". The following induces an error, until -std is added to get
proper ANSI mode. Curiously \x00 != x always comes out true, for an
array size at least. It is necessary to write \x00 == 0 to get something
that is true only with -std. */
int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];
/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
inside strings and character constants. */
#define FOO(x) '\''x'\''
int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];
int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),
int, int);'
# Test code for whether the C compiler supports C89 (body of main).
ac_c_conftest_c89_main='
ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);
'
# Test code for whether the C compiler supports C99 (global declarations)
ac_c_conftest_c99_globals='
// Does the compiler advertise C99 conformance?
#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
# error "Compiler does not advertise C99 conformance"
#endif
#include <stdbool.h>
extern int puts (const char *);
extern int printf (const char *, ...);
extern int dprintf (int, const char *, ...);
extern void *malloc (size_t);
// Check varargs macros. These examples are taken from C99 6.10.3.5.
// dprintf is used instead of fprintf to avoid needing to declare
// FILE and stderr.
#define debug(...) dprintf (2, __VA_ARGS__)
#define showlist(...) puts (#__VA_ARGS__)
#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))
static void
test_varargs_macros (void)
{
int x = 1234;
int y = 5678;
debug ("Flag");
debug ("X = %d\n", x);
showlist (The first, second, and third items.);
report (x>y, "x is %d but y is %d", x, y);
}
// Check long long types.
#define BIG64 18446744073709551615ull
#define BIG32 4294967295ul
#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)
#if !BIG_OK
#error "your preprocessor is broken"
#endif
#if BIG_OK
#else
#error "your preprocessor is broken"
#endif
static long long int bignum = -9223372036854775807LL;
static unsigned long long int ubignum = BIG64;
struct incomplete_array
{
int datasize;
double data[];
};
struct named_init {
int number;
const wchar_t *name;
double average;
};
typedef const char *ccp;
static inline int
test_restrict (ccp restrict text)
{
// See if C++-style comments work.
// Iterate through items via the restricted pointer.
// Also check for declarations in for loops.
for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)
continue;
return 0;
}
// Check varargs and va_copy.
static bool
test_varargs (const char *format, ...)
{
va_list args;
va_start (args, format);
va_list args_copy;
va_copy (args_copy, args);
const char *str = "";
int number = 0;
float fnumber = 0;
while (*format)
{
switch (*format++)
{
case '\''s'\'': // string
str = va_arg (args_copy, const char *);
break;
case '\''d'\'': // int
number = va_arg (args_copy, int);
break;
case '\''f'\'': // float
fnumber = va_arg (args_copy, double);
break;
default:
break;
}
}
va_end (args_copy);
va_end (args);
return *str && number && fnumber;
}
'
# Test code for whether the C compiler supports C99 (body of main).
ac_c_conftest_c99_main='
// Check bool.
_Bool success = false;
success |= (argc != 0);
// Check restrict.
if (test_restrict ("String literal") == 0)
success = true;
char *restrict newvar = "Another string";
// Check varargs.
success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);
test_varargs_macros ();
// Check flexible array members.
struct incomplete_array *ia =
malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));
ia->datasize = 10;
for (int i = 0; i < ia->datasize; ++i)
ia->data[i] = i * 1.234;
// Check named initializers.
struct named_init ni = {
.number = 34,
.name = L"Test wide string",
.average = 543.34343,
};
ni.number = 58;
int dynamic_array[ni.number];
dynamic_array[0] = argv[0][0];
dynamic_array[ni.number - 1] = 543;
// work around unused variable warnings
ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''
|| dynamic_array[ni.number - 1] != 543);
'
# Test code for whether the C compiler supports C11 (global declarations)
ac_c_conftest_c11_globals='
// Does the compiler advertise C11 conformance?
#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L
# error "Compiler does not advertise C11 conformance"
#endif
// Check _Alignas.
char _Alignas (double) aligned_as_double;
char _Alignas (0) no_special_alignment;
extern char aligned_as_int;
char _Alignas (0) _Alignas (int) aligned_as_int;
// Check _Alignof.
enum
{
int_alignment = _Alignof (int),
int_array_alignment = _Alignof (int[100]),
char_alignment = _Alignof (char)
};
_Static_assert (0 < -_Alignof (int), "_Alignof is signed");
// Check _Noreturn.
int _Noreturn does_not_return (void) { for (;;) continue; }
// Check _Static_assert.
struct test_static_assert
{
int x;
_Static_assert (sizeof (int) <= sizeof (long int),
"_Static_assert does not work in struct");
long int y;
};
// Check UTF-8 literals.
#define u8 syntax error!
char const utf8_literal[] = u8"happens to be ASCII" "another string";
// Check duplicate typedefs.
typedef long *long_ptr;
typedef long int *long_ptr;
typedef long_ptr long_ptr;
// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.
struct anonymous
{
union {
struct { int i; int j; };
struct { int k; long int l; } w;
};
int m;
} v1;
'
# Test code for whether the C compiler supports C11 (body of main).
ac_c_conftest_c11_main='
_Static_assert ((offsetof (struct anonymous, i)
== offsetof (struct anonymous, w.k)),
"Anonymous union alignment botch");
v1.i = 2;
v1.w.k = 5;
ok |= v1.i != 5;
'
# Test code for whether the C compiler supports C11 (complete).
ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}
${ac_c_conftest_c99_globals}
${ac_c_conftest_c11_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
${ac_c_conftest_c99_main}
${ac_c_conftest_c11_main}
return ok;
}
"
# Test code for whether the C compiler supports C99 (complete).
ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}
${ac_c_conftest_c99_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
${ac_c_conftest_c99_main}
return ok;
}
"
# Test code for whether the C compiler supports C89 (complete).
ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
return ok;
}
"
as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"
as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"
as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"
as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"
as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"
as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"
as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"
as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"
as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"
as_fn_append ac_header_c_list " sys/time.h sys_time_h HAVE_SYS_TIME_H"
# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in $ac_precious_vars; do
eval ac_old_set=\$ac_cv_env_${ac_var}_set
eval ac_new_set=\$ac_env_${ac_var}_set
eval ac_old_val=\$ac_cv_env_${ac_var}_value
eval ac_new_val=\$ac_env_${ac_var}_value
case $ac_old_set,$ac_new_set in
set,)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
ac_cache_corrupted=: ;;
,set)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
ac_cache_corrupted=: ;;
,);;
*)
if test "x$ac_old_val" != "x$ac_new_val"; then
# differences in whitespace do not lead to failure.
ac_old_val_w=`echo x $ac_old_val`
ac_new_val_w=`echo x $ac_new_val`
if test "$ac_old_val_w" != "$ac_new_val_w"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
ac_cache_corrupted=:
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
eval $ac_var=\$ac_old_val
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;}
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;}
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
*\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
*) ac_arg=$ac_var=$ac_new_val ;;
esac
case " $ac_configure_args " in
*" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
*) as_fn_append ac_configure_args " '$ac_arg'" ;;
esac
fi
done
if $ac_cache_corrupted; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}
as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file'
and start over" "$LINENO" 5
fi
## -------------------- ##
## Main body of script. ##
## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
|
| ︙ | ︙ | |||
2432 2433 2434 2435 2436 2437 2438 | TCL_SRC_DIR="`cd "$srcdir"/..; pwd`" #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ | | | | > | | | | | | > | | | | | | | | | | > | | | > > > > > > > > > | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > | | | > | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | > | | | | > | | | | > > | | | | > | | | | > | | | > | | | > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > | | | | | | | | | > | | | > > > > > > > > > | | | > | | | | | > | | | | 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 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 |
TCL_SRC_DIR="`cd "$srcdir"/..; pwd`"
#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use symlinks for manpages" >&5
printf %s "checking whether to use symlinks for manpages... " >&6; }
# Check whether --enable-man-symlinks was given.
if test ${enable_man_symlinks+y}
then :
enableval=$enable_man_symlinks; test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
else $as_nop
enableval="no"
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
printf "%s\n" "$enableval" >&6; }
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to compress the manpages" >&5
printf %s "checking whether to compress the manpages... " >&6; }
# Check whether --enable-man-compression was given.
if test ${enable_man_compression+y}
then :
enableval=$enable_man_compression; case $enableval in
yes) as_fn_error $? "missing argument to --enable-man-compression" "$LINENO" 5;;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
esac
else $as_nop
enableval="no"
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
printf "%s\n" "$enableval" >&6; }
if test "$enableval" != "no"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for compressed file suffix" >&5
printf %s "checking for compressed file suffix... " >&6; }
touch TeST
$enableval TeST
Z=`ls TeST* | sed 's/^....//'`
rm -f TeST*
MAN_FLAGS="$MAN_FLAGS --extension $Z"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $Z" >&5
printf "%s\n" "$Z" >&6; }
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to add a package name suffix for the manpages" >&5
printf %s "checking whether to add a package name suffix for the manpages... " >&6; }
# Check whether --enable-man-suffix was given.
if test ${enable_man_suffix+y}
then :
enableval=$enable_man_suffix; case $enableval in
yes) enableval="tcl" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
esac
else $as_nop
enableval="no"
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
printf "%s\n" "$enableval" >&6; }
#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
set dummy ${ac_tool_prefix}gcc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}gcc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="gcc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
else
CC="$ac_cv_prog_CC"
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
set dummy ${ac_tool_prefix}cc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}cc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
fi
if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
ac_prog_rejected=no
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
ac_prog_rejected=yes
continue
fi
ac_cv_prog_CC="cc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
if test $ac_prog_rejected = yes; then
# We found a bogon in the path, so make sure we never use it.
set dummy $ac_cv_prog_CC
shift
if test $# != 0; then
# We chose a different compiler from the bogus one.
# However, it has the same basename, so the bogon will be chosen
# first if we set CC to just the basename; use the full file name.
shift
ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"
fi
fi
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
for ac_prog in cl.exe
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
test -n "$CC" && break
done
fi
if test -z "$CC"; then
ac_ct_CC=$CC
for ac_prog in cl.exe
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="$ac_prog"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
test -n "$ac_ct_CC" && break
done
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
fi
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.
set dummy ${ac_tool_prefix}clang; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}clang"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "clang", so it can be a program name with args.
set dummy clang; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="clang"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
else
CC="$ac_cv_prog_CC"
fi
fi
test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "no acceptable C compiler found in \$PATH
See \`config.log' for more details" "$LINENO" 5; }
# Provide some information about the compiler.
printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
set X $ac_compile
ac_compiler=$2
for ac_option in --version -v -V -qversion -version; do
{ { ac_try="$ac_compiler $ac_option >&5"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compiler $ac_option >&5") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
sed '10a\
... rest of stderr output deleted ...
10q' conftest.err >conftest.er1
cat conftest.er1 >&5
fi
rm -f conftest.er1 conftest.err
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
done
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
printf %s "checking whether the C compiler works... " >&6; }
ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
# The possible output files:
ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
ac_rmfiles=
for ac_file in $ac_files
do
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
* ) ac_rmfiles="$ac_rmfiles $ac_file";;
esac
done
rm -f $ac_rmfiles
if { { ac_try="$ac_link_default"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link_default") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
# Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
# in a Makefile. We should not override ac_cv_exeext if it was cached,
# so that the user can short-circuit this test for compilers unknown to
# Autoconf.
for ac_file in $ac_files ''
do
test -f "$ac_file" || continue
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
;;
[ab].out )
# We found the default executable, but exeext='' is most
# certainly right.
break;;
*.* )
if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;
then :; else
ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
fi
# We set ac_cv_exeext here because the later test for it is not
# safe: cross compilers may not add the suffix if given an `-o'
# argument, so we may need to know it at that point already.
# Even if this section looks crufty: it has the advantage of
# actually working.
break;;
* )
break;;
esac
done
test "$ac_cv_exeext" = no && ac_cv_exeext=
else $as_nop
ac_file=''
fi
if test -z "$ac_file"
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error 77 "C compiler cannot create executables
See \`config.log' for more details" "$LINENO" 5; }
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
printf %s "checking for C compiler default output file name... " >&6; }
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
printf "%s\n" "$ac_file" >&6; }
ac_exeext=$ac_cv_exeext
rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
ac_clean_files=$ac_clean_files_save
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
printf %s "checking for suffix of executables... " >&6; }
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
# If both `conftest.exe' and `conftest' are `present' (well, observable)
# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
test -f "$ac_file" || continue
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
*.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
break;;
* ) break;;
esac
done
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details" "$LINENO" 5; }
fi
rm -f conftest conftest$ac_cv_exeext
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
printf "%s\n" "$ac_cv_exeext" >&6; }
rm -f conftest.$ac_ext
EXEEXT=$ac_cv_exeext
ac_exeext=$EXEEXT
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdio.h>
int
main (void)
{
FILE *f = fopen ("conftest.out", "w");
return ferror (f) || fclose (f) != 0;
;
return 0;
}
_ACEOF
ac_clean_files="$ac_clean_files conftest.out"
# Check that the compiler produces executables we can run. If not, either
# the compiler is broken, or we cross compile.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
printf %s "checking whether we are cross compiling... " >&6; }
if test "$cross_compiling" != yes; then
{ { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
if { ac_try='./conftest$ac_cv_exeext'
{ { case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_try") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }; }; then
cross_compiling=no
else
if test "$cross_compiling" = maybe; then
cross_compiling=yes
else
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error 77 "cannot run C compiled programs.
If you meant to cross compile, use \`--host'.
See \`config.log' for more details" "$LINENO" 5; }
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
printf "%s\n" "$cross_compiling" >&6; }
rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
ac_clean_files=$ac_clean_files_save
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
printf %s "checking for suffix of object files... " >&6; }
if test ${ac_cv_objext+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
rm -f conftest.o conftest.obj
if { { ac_try="$ac_compile"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compile") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
for ac_file in conftest.o conftest.obj conftest.*; do
test -f "$ac_file" || continue;
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
*) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
break;;
esac
done
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot compute suffix of object files: cannot compile
See \`config.log' for more details" "$LINENO" 5; }
fi
rm -f conftest.$ac_cv_objext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
printf "%s\n" "$ac_cv_objext" >&6; }
OBJEXT=$ac_cv_objext
ac_objext=$OBJEXT
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5
printf %s "checking whether the compiler supports GNU C... " >&6; }
if test ${ac_cv_c_compiler_gnu+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
#ifndef __GNUC__
choke me
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_compiler_gnu=yes
else $as_nop
ac_compiler_gnu=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test $ac_compiler_gnu = yes; then
GCC=yes
else
GCC=
fi
ac_test_CFLAGS=${CFLAGS+y}
ac_save_CFLAGS=$CFLAGS
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
printf %s "checking whether $CC accepts -g... " >&6; }
if test ${ac_cv_prog_cc_g+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_save_c_werror_flag=$ac_c_werror_flag
ac_c_werror_flag=yes
ac_cv_prog_cc_g=no
CFLAGS="-g"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_g=yes
else $as_nop
CFLAGS=""
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
else $as_nop
ac_c_werror_flag=$ac_save_c_werror_flag
CFLAGS="-g"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_g=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_c_werror_flag=$ac_save_c_werror_flag
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
printf "%s\n" "$ac_cv_prog_cc_g" >&6; }
if test $ac_test_CFLAGS; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
if test "$GCC" = yes; then
CFLAGS="-g -O2"
else
CFLAGS="-g"
fi
else
if test "$GCC" = yes; then
CFLAGS="-O2"
else
CFLAGS=
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5
printf %s "checking for $CC option to enable C11 features... " >&6; }
if test ${ac_cv_prog_cc_c11+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c11=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c11_program
_ACEOF
for ac_arg in '' -std=gnu11
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c11=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c11" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c11" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c11"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5
printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c11" != xno
then :
ac_prog_cc_stdc=c11
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5
printf %s "checking for $CC option to enable C99 features... " >&6; }
if test ${ac_cv_prog_cc_c99+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c99=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c89_program
_ACEOF
for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc1x -qlanglvl=extc99
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c99=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c99" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c99" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c99"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5
printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c99" != xno
then :
ac_prog_cc_stdc=c99
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5
printf %s "checking for $CC option to enable C89 features... " >&6; }
if test ${ac_cv_prog_cc_c89+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c89=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c89_program
_ACEOF
for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \
-Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c89=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c89" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c89" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c89"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c89" != xno
then :
ac_prog_cc_stdc=c89
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89
else $as_nop
ac_prog_cc_stdc=no
ac_cv_prog_cc_stdc=no
fi
fi
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
printf %s "checking for inline... " >&6; }
if test ${ac_cv_c_inline+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_c_inline=no
for ac_kw in inline __inline__ __inline; do
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef __cplusplus
typedef int foo_t;
static $ac_kw foo_t static_foo (void) {return 0; }
$ac_kw foo_t foo (void) {return 0; }
#endif
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_c_inline=$ac_kw
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
test "$ac_cv_c_inline" != no && break
done
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
printf "%s\n" "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
*)
case $ac_cv_c_inline in
no) ac_val=;;
*) ac_val=$ac_cv_c_inline;;
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 | # - stdlib.h doesn't define strtol or strtoul in some versions # of SunOS # - some versions of string.h don't declare procedures such # as strstr # Do this early, otherwise an autoconf bug throws errors on configure #-------------------------------------------------------------------- ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | | | < < < | < < < | > | | > | | > | | < < < | < < < | > | | > | | > | | | | | | > | | > | > > > | > | | | | 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 |
# - stdlib.h doesn't define strtol or strtoul in some versions
# of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------
ac_header= ac_cache=
for ac_item in $ac_header_c_list
do
if test $ac_cache; then
ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"
if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then
printf "%s\n" "#define $ac_item 1" >> confdefs.h
fi
ac_header= ac_cache=
elif test $ac_header; then
ac_cache=$ac_item
else
ac_header=$ac_item
fi
done
if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes
then :
printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
printf %s "checking how to run the C preprocessor... " >&6; }
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
fi
if test -z "$CPP"; then
if test ${ac_cv_prog_CPP+y}
then :
printf %s "(cached) " >&6
else $as_nop
# Double quotes because $CC needs to be expanded
for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp
do
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
Syntax error
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
else $as_nop
# Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.i conftest.$ac_ext
# OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
# Broken: success on invalid input.
continue
else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
rm -f conftest.i conftest.err conftest.$ac_ext
if $ac_preproc_ok
then :
break
fi
done
ac_cv_prog_CPP=$CPP
fi
CPP=$ac_cv_prog_CPP
else
ac_cv_prog_CPP=$CPP
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
printf "%s\n" "$CPP" >&6; }
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
Syntax error
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
else $as_nop
# Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.i conftest.$ac_ext
# OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
# Broken: success on invalid input.
continue
else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
rm -f conftest.i conftest.err conftest.$ac_ext
if $ac_preproc_ok
then :
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
See \`config.log' for more details" "$LINENO" 5; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
printf %s "checking for grep that handles long lines and -e... " >&6; }
if test ${ac_cv_path_GREP+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -z "$GREP"; then
ac_path_GREP_found=false
# Loop through the user's path and test for each of PROGNAME-LIST
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_prog in grep ggrep
do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_GREP="$as_dir$ac_prog$ac_exec_ext"
as_fn_executable_p "$ac_path_GREP" || continue
# Check for GNU ac_path_GREP and select it if it is found.
# Check for GNU $ac_path_GREP
case `"$ac_path_GREP" --version 2>&1` in
*GNU*)
ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
*)
ac_count=0
printf %s 0123456789 >"conftest.in"
while :
do
cat "conftest.in" "conftest.in" >"conftest.tmp"
mv "conftest.tmp" "conftest.in"
cp "conftest.in" "conftest.nl"
printf "%s\n" 'GREP' >> "conftest.nl"
"$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
as_fn_arith $ac_count + 1 && ac_count=$as_val
if test $ac_count -gt ${ac_path_GREP_max-0}; then
# Best one so far, save it but keep looking for a better one
ac_cv_path_GREP="$ac_path_GREP"
ac_path_GREP_max=$ac_count
|
| ︙ | ︙ | |||
3539 3540 3541 3542 3543 3544 3545 |
as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
fi
else
ac_cv_path_GREP=$GREP
fi
fi
| | | | | | > | | > | > > > | > | | | | 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 |
as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
fi
else
ac_cv_path_GREP=$GREP
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
printf "%s\n" "$ac_cv_path_GREP" >&6; }
GREP="$ac_cv_path_GREP"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
printf %s "checking for egrep... " >&6; }
if test ${ac_cv_path_EGREP+y}
then :
printf %s "(cached) " >&6
else $as_nop
if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
then ac_cv_path_EGREP="$GREP -E"
else
if test -z "$EGREP"; then
ac_path_EGREP_found=false
# Loop through the user's path and test for each of PROGNAME-LIST
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_prog in egrep
do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext"
as_fn_executable_p "$ac_path_EGREP" || continue
# Check for GNU ac_path_EGREP and select it if it is found.
# Check for GNU $ac_path_EGREP
case `"$ac_path_EGREP" --version 2>&1` in
*GNU*)
ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
*)
ac_count=0
printf %s 0123456789 >"conftest.in"
while :
do
cat "conftest.in" "conftest.in" >"conftest.tmp"
mv "conftest.tmp" "conftest.in"
cp "conftest.in" "conftest.nl"
printf "%s\n" 'EGREP' >> "conftest.nl"
"$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
as_fn_arith $ac_count + 1 && ac_count=$as_val
if test $ac_count -gt ${ac_path_EGREP_max-0}; then
# Best one so far, save it but keep looking for a better one
ac_cv_path_EGREP="$ac_path_EGREP"
ac_path_EGREP_max=$ac_count
|
| ︙ | ︙ | |||
3606 3607 3608 3609 3610 3611 3612 | fi else ac_cv_path_EGREP=$EGREP fi fi fi | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | > | | | | 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 |
fi
else
ac_cv_path_EGREP=$EGREP
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
printf "%s\n" "$ac_cv_path_EGREP" >&6; }
EGREP="$ac_cv_path_EGREP"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking dirent.h" >&5
printf %s "checking dirent.h... " >&6; }
if test ${tcl_cv_dirent_h+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
main (void)
{
#ifndef _POSIX_SOURCE
# ifdef __Lynx__
/*
* Generate compilation error to make the test fail: Lynx headers
* are only valid if really in the POSIX environment.
|
| ︙ | ︙ | |||
3777 3778 3779 3780 3781 3782 3783 | p = entryPtr->d_name; closedir(d); ; return 0; } _ACEOF | | > | | | | | | | > | < | > | | | > | | | | | > | > > > > > > > > > > > > > < < < < < < < < < < < < < | > | | | | | > | | < | | > | | < < < | | < > | < < < | | | > | | | | > | | | | | > < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | | > | | | | > | | | | | > | | > | < | 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 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 |
p = entryPtr->d_name;
closedir(d);
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_dirent_h=yes
else $as_nop
tcl_cv_dirent_h=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_dirent_h" >&5
printf "%s\n" "$tcl_cv_dirent_h" >&6; }
if test $tcl_cv_dirent_h = no; then
printf "%s\n" "#define NO_DIRENT_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default"
if test "x$ac_cv_header_stdlib_h" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "strtol" >/dev/null 2>&1
then :
else $as_nop
tcl_ok=0
fi
rm -rf conftest*
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "strtoul" >/dev/null 2>&1
then :
else $as_nop
tcl_ok=0
fi
rm -rf conftest*
if test $tcl_ok = 0; then
printf "%s\n" "#define NO_STDLIB_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "string.h" "ac_cv_header_string_h" "$ac_includes_default"
if test "x$ac_cv_header_string_h" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "strstr" >/dev/null 2>&1
then :
else $as_nop
tcl_ok=0
fi
rm -rf conftest*
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <string.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "strerror" >/dev/null 2>&1
then :
else $as_nop
tcl_ok=0
fi
rm -rf conftest*
# See also memmove check below for a place where NO_STRING_H can be
# set and why.
if test $tcl_ok = 0; then
printf "%s\n" "#define NO_STRING_H 1" >>confdefs.h
fi
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 $as_nop
printf "%s\n" "#define NO_SYS_WAIT_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default"
if test "x$ac_cv_header_dlfcn_h" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_DLFCN_H 1" >>confdefs.h
fi
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
ac_fn_c_check_header_compile "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_param_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_PARAM_H 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Determines the correct executable file extension (.exe)
#--------------------------------------------------------------------
#------------------------------------------------------------------------
# If we're using GCC, see if the compiler understands -pipe. If so, use it.
# It makes compiling go faster. (This is only a performance feature.)
#------------------------------------------------------------------------
if test -z "$no_pipe" && test -n "$GCC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5
printf %s "checking if the compiler understands -pipe... " >&6; }
if test ${tcl_cv_cc_pipe+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_cc_pipe=yes
else $as_nop
tcl_cv_cc_pipe=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
CFLAGS=$hold_cflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
printf "%s\n" "$tcl_cv_cc_pipe" >&6; }
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
# Check whether --with-encoding was given.
if test ${with_encoding+y}
then :
withval=$with_encoding; with_tcencoding=${withval}
fi
if test x"${with_tcencoding}" != x ; then
printf "%s\n" "#define TCL_CFGVAL_ENCODING \"${with_tcencoding}\"" >>confdefs.h
else
printf "%s\n" "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
fi
#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------
# The Clang compiler raises a warning for an undeclared identifier that matches
# a compiler builtin function. All extant Clang versions are affected, as of
# Clang 3.6.0. Test a builtin known to every version. This problem affects the
# C and Objective C languages, but Clang does report an error under C++ and
# Objective C++.
#
# Passing -fno-builtin to the compiler would suppress this problem. That
# strategy would have the advantage of being insensitive to stray warnings, but
# it would make tests less realistic.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how $CC reports undeclared, standard C functions" >&5
printf %s "checking how $CC reports undeclared, standard C functions... " >&6; }
if test ${ac_cv_c_decl_report+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
(void) strchr;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
if test -s conftest.err
then :
# For AC_CHECK_DECL to react to warnings, the compiler must be silent on
# valid AC_CHECK_DECL input. No library function is consistently available
# on freestanding implementations, so test against a dummy declaration.
# Include always-available headers on the off chance that they somehow
# elicit warnings.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <float.h>
#include <limits.h>
#include <stdarg.h>
#include <stddef.h>
extern void ac_decl (int, char *);
int
main (void)
{
#ifdef __cplusplus
(void) ac_decl ((int) 0, (char *) 0);
(void) ac_decl;
#else
(void) ac_decl;
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
if test -s conftest.err
then :
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot detect from compiler exit status or warnings
See \`config.log' for more details" "$LINENO" 5; }
else $as_nop
ac_cv_c_decl_report=warning
fi
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot compile a simple declaration test
See \`config.log' for more details" "$LINENO" 5; }
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "compiler does not report undeclared identifiers
See \`config.log' for more details" "$LINENO" 5; }
fi
else $as_nop
ac_cv_c_decl_report=error
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_decl_report" >&5
printf "%s\n" "$ac_cv_c_decl_report" >&6; }
case $ac_cv_c_decl_report in
warning) ac_c_decl_warn_flag=yes ;;
*) ac_c_decl_warn_flag= ;;
esac
#--------------------------------------------------------------------
# On a few very rare systems, all of the libm.a stuff is
# already in libc.a. Set compiler flags accordingly.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin"
if test "x$ac_cv_func_sin" = xyes
then :
MATH_LIBS=""
else $as_nop
MATH_LIBS="-lm"
fi
#--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5
printf %s "checking for main in -linet... " >&6; }
if test ${ac_cv_lib_inet_main+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-linet $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
return main ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_inet_main=yes
else $as_nop
ac_cv_lib_inet_main=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_main" >&5
printf "%s\n" "$ac_cv_lib_inet_main" >&6; }
if test "x$ac_cv_lib_inet_main" = xyes
then :
LIBS="$LIBS -linet"
fi
ac_fn_c_check_header_compile "$LINENO" "net/errno.h" "ac_cv_header_net_errno_h" "$ac_includes_default"
if test "x$ac_cv_header_net_errno_h" = xyes
then :
printf "%s\n" "#define HAVE_NET_ERRNO_H 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check for the existence of the -lsocket and -lnsl libraries.
# The order here is important, so that they end up in the right
# order in the command line generated by make. Here are some
# special considerations:
|
| ︙ | ︙ | |||
4070 4071 4072 4073 4074 4075 4076 |
# 4. On some SVR4 systems, can't use -lsocket without -lnsl too.
# To get around this problem, check for both libraries together
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
tcl_checkBoth=0
ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect"
| | > | | > | | | | > | | < < < | | > | | | | | > | | > | | > | | | | > | | < < < | | > | | | | | > | | | | | > | | < < < | | > | | | | | > | | | | > | | < < < | | > | | | | | > | | | | > | | < < < | | > | | | | | > | | | | > | | < < < | | > | | | | | > | | | | > | | < < < | | > | | | | | > | | | > | | > | > | > | | < < < | > | < | < | > | | | | > | < < < < < < < < | | | | | | | | > | | | | | | | | > | > | | < | > | | | > | | < < < | | > | > | | > | > | | | | > | | > | | > | | > | > | | < | > | | | > | | < < < | | > | | | | | > | | > | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | | | | | > | | | | > | | | > | | | | > | | | | | > | | | | | > | | | | | | > | | | | | | | | | > | | < < < | | > | | | | | > | | 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 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 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 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 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 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 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 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 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 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 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 5419 5420 5421 5422 5423 5424 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 5453 5454 5455 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 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 |
# 4. On some SVR4 systems, can't use -lsocket without -lnsl too.
# To get around this problem, check for both libraries together
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
tcl_checkBoth=0
ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect"
if test "x$ac_cv_func_connect" = xyes
then :
tcl_checkSocket=0
else $as_nop
tcl_checkSocket=1
fi
if test "$tcl_checkSocket" = 1; then
ac_fn_c_check_func "$LINENO" "setsockopt" "ac_cv_func_setsockopt"
if test "x$ac_cv_func_setsockopt" = xyes
then :
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5
printf %s "checking for setsockopt in -lsocket... " >&6; }
if test ${ac_cv_lib_socket_setsockopt+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char setsockopt ();
int
main (void)
{
return setsockopt ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_socket_setsockopt=yes
else $as_nop
ac_cv_lib_socket_setsockopt=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5
printf "%s\n" "$ac_cv_lib_socket_setsockopt" >&6; }
if test "x$ac_cv_lib_socket_setsockopt" = xyes
then :
LIBS="$LIBS -lsocket"
else $as_nop
tcl_checkBoth=1
fi
fi
fi
if test "$tcl_checkBoth" = 1; then
tk_oldLibs=$LIBS
LIBS="$LIBS -lsocket -lnsl"
ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept"
if test "x$ac_cv_func_accept" = xyes
then :
tcl_checkNsl=0
else $as_nop
LIBS=$tk_oldLibs
fi
fi
ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname"
if test "x$ac_cv_func_gethostbyname" = xyes
then :
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5
printf %s "checking for gethostbyname in -lnsl... " >&6; }
if test ${ac_cv_lib_nsl_gethostbyname+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lnsl $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char gethostbyname ();
int
main (void)
{
return gethostbyname ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_nsl_gethostbyname=yes
else $as_nop
ac_cv_lib_nsl_gethostbyname=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5
printf "%s\n" "$ac_cv_lib_nsl_gethostbyname" >&6; }
if test "x$ac_cv_lib_nsl_gethostbyname" = xyes
then :
LIBS="$LIBS -lnsl"
fi
fi
printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
printf "%s\n" "#define _THREAD_SAFE 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5
printf %s "checking for pthread_mutex_init in -lpthread... " >&6; }
if test ${ac_cv_lib_pthread_pthread_mutex_init+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char pthread_mutex_init ();
int
main (void)
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_pthread_pthread_mutex_init=yes
else $as_nop
ac_cv_lib_pthread_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
printf "%s\n" "$ac_cv_lib_pthread_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = "no"; then
# Check a little harder for __pthread_mutex_init in the same
# library, as some systems hide it there until pthread.h is
# defined. We could alternatively do an AC_TRY_COMPILE with
# pthread.h, but that will work with libpthread really doesn't
# exist, like AIX 4.2. [Bug: 4359]
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5
printf %s "checking for __pthread_mutex_init in -lpthread... " >&6; }
if test ${ac_cv_lib_pthread___pthread_mutex_init+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthread $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char __pthread_mutex_init ();
int
main (void)
{
return __pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_pthread___pthread_mutex_init=yes
else $as_nop
ac_cv_lib_pthread___pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
printf "%s\n" "$ac_cv_lib_pthread___pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthread"
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5
printf %s "checking for pthread_mutex_init in -lpthreads... " >&6; }
if test ${ac_cv_lib_pthreads_pthread_mutex_init+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lpthreads $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char pthread_mutex_init ();
int
main (void)
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_pthreads_pthread_mutex_init=yes
else $as_nop
ac_cv_lib_pthreads_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
printf "%s\n" "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes
then :
_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthreads"
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5
printf %s "checking for pthread_mutex_init in -lc... " >&6; }
if test ${ac_cv_lib_c_pthread_mutex_init+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lc $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char pthread_mutex_init ();
int
main (void)
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_c_pthread_mutex_init=yes
else $as_nop
ac_cv_lib_c_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5
printf "%s\n" "$ac_cv_lib_c_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = "no"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5
printf %s "checking for pthread_mutex_init in -lc_r... " >&6; }
if test ${ac_cv_lib_c_r_pthread_mutex_init+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lc_r $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char pthread_mutex_init ();
int
main (void)
{
return pthread_mutex_init ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_c_r_pthread_mutex_init=yes
else $as_nop
ac_cv_lib_c_r_pthread_mutex_init=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
printf "%s\n" "$ac_cv_lib_c_r_pthread_mutex_init" >&6; }
if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -pthread"
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&5
printf "%s\n" "$as_me: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&2;}
fi
fi
fi
fi
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
ac_fn_c_check_func "$LINENO" "pthread_attr_setstacksize" "ac_cv_func_pthread_attr_setstacksize"
if test "x$ac_cv_func_pthread_attr_setstacksize" = xyes
then :
printf "%s\n" "#define HAVE_PTHREAD_ATTR_SETSTACKSIZE 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "pthread_atfork" "ac_cv_func_pthread_atfork"
if test "x$ac_cv_func_pthread_atfork" = xyes
then :
printf "%s\n" "#define HAVE_PTHREAD_ATFORK 1" >>confdefs.h
fi
LIBS=$ac_saved_libs
# TIP #509
ac_fn_c_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include <pthread.h>
"
if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes
then :
ac_have_decl=1
else $as_nop
ac_have_decl=0
fi
printf "%s\n" "#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl" >>confdefs.h
if test $ac_have_decl = 1
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
printf %s "checking how to build libraries... " >&6; }
# Check whether --enable-shared was given.
if test ${enable_shared+y}
then :
enableval=$enable_shared; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5
printf "%s\n" "shared" >&6; }
SHARED_BUILD=1
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5
printf "%s\n" "static" >&6; }
SHARED_BUILD=0
printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Look for a native installed tclsh binary (if available)
# If one cannot be found then use the binary we build (fails for
# cross compiling). This is used for NATIVE_TCLSH in Makefile.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
printf %s "checking for tclsh... " >&6; }
if test ${ac_cv_path_tclsh+y}
then :
printf %s "(cached) " >&6
else $as_nop
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/tclsh[8-9]* 2> /dev/null` \
`ls -r $dir/tclsh* 2> /dev/null` ; do
if test x"$ac_cv_path_tclsh" = x ; then
if test -f "$j" ; then
ac_cv_path_tclsh=$j
break
fi
fi
done
done
fi
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
printf "%s\n" "$TCLSH_PROG" >&6; }
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
printf "%s\n" "No tclsh found on PATH" >&6; }
fi
if test "$TCLSH_PROG" = ""; then
TCLSH_PROG='./${TCL_EXE}'
fi
#------------------------------------------------------------------------
# Add stuff for zlib
#------------------------------------------------------------------------
zlib_ok=yes
ac_fn_c_check_header_compile "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default"
if test "x$ac_cv_header_zlib_h" = xyes
then :
ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include <zlib.h>
"
if test "x$ac_cv_type_gz_header" = xyes
then :
else $as_nop
zlib_ok=no
fi
else $as_nop
zlib_ok=no
fi
if test $zlib_ok = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5
printf %s "checking for library containing deflateSetHeader... " >&6; }
if test ${ac_cv_search_deflateSetHeader+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_func_search_save_LIBS=$LIBS
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char deflateSetHeader ();
int
main (void)
{
return deflateSetHeader ();
;
return 0;
}
_ACEOF
for ac_lib in '' z
do
if test -z "$ac_lib"; then
ac_res="none required"
else
ac_res=-l$ac_lib
LIBS="-l$ac_lib $ac_func_search_save_LIBS"
fi
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_search_deflateSetHeader=$ac_res
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext
if test ${ac_cv_search_deflateSetHeader+y}
then :
break
fi
done
if test ${ac_cv_search_deflateSetHeader+y}
then :
else $as_nop
ac_cv_search_deflateSetHeader=no
fi
rm conftest.$ac_ext
LIBS=$ac_func_search_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5
printf "%s\n" "$ac_cv_search_deflateSetHeader" >&6; }
ac_res=$ac_cv_search_deflateSetHeader
if test "$ac_res" != no
then :
test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"
else $as_nop
zlib_ok=no
fi
fi
if test $zlib_ok = no
then :
ZLIB_OBJS=\${ZLIB_OBJS}
ZLIB_SRCS=\${ZLIB_SRCS}
ZLIB_INCLUDE=-I\${ZLIB_DIR}
fi
printf "%s\n" "#define HAVE_ZLIB 1" >>confdefs.h
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
# Check whether --with-system-libtommath was given.
if test ${with_system_libtommath+y}
then :
withval=$with_system_libtommath; libtommath_ok=${withval}
fi
if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
ac_fn_c_check_header_compile "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default"
if test "x$ac_cv_header_tommath_h" = xyes
then :
ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include <tommath.h>
"
if test "x$ac_cv_type_mp_int" = xyes
then :
else $as_nop
libtommath_ok=no
fi
else $as_nop
libtommath_ok=no
fi
if test $libtommath_ok = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5
printf %s "checking for mp_log_u32 in -ltommath... " >&6; }
if test ${ac_cv_lib_tommath_mp_log_u32+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ltommath $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char mp_log_u32 ();
int
main (void)
{
return mp_log_u32 ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_tommath_mp_log_u32=yes
else $as_nop
ac_cv_lib_tommath_mp_log_u32=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5
printf "%s\n" "$ac_cv_lib_tommath_mp_log_u32" >&6; }
if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes
then :
MATH_LIBS="$MATH_LIBS -ltommath"
else $as_nop
libtommath_ok=no
fi
fi
fi
if test $libtommath_ok = yes
then :
printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
else $as_nop
TOMMATH_OBJS=\${TOMMATH_OBJS}
TOMMATH_SRCS=\${TOMMATH_SRCS}
TOMMATH_INCLUDE=-I\${TOMMATH_DIR}
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
set dummy ${ac_tool_prefix}ranlib; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_RANLIB+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
RANLIB=$ac_cv_prog_RANLIB
if test -n "$RANLIB"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
printf "%s\n" "$RANLIB" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_RANLIB"; then
ac_ct_RANLIB=$RANLIB
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_RANLIB+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RANLIB="ranlib"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
if test -n "$ac_ct_RANLIB"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
printf "%s\n" "$ac_ct_RANLIB" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_RANLIB" = x; then
RANLIB=":"
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
RANLIB=$ac_ct_RANLIB
fi
else
RANLIB="$ac_cv_prog_RANLIB"
fi
# Step 0.a: Enable 64 bit support?
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
printf %s "checking if 64bit support is requested... " >&6; }
# Check whether --enable-64bit was given.
if test ${enable_64bit+y}
then :
enableval=$enable_64bit; do64bit=$enableval
else $as_nop
do64bit=no
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
printf "%s\n" "$do64bit" >&6; }
# Step 0.b: Enable Solaris 64 bit VIS support?
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5
printf %s "checking if 64bit Sparc VIS support is requested... " >&6; }
# Check whether --enable-64bit-vis was given.
if test ${enable_64bit_vis+y}
then :
enableval=$enable_64bit_vis; do64bitVIS=$enableval
else $as_nop
do64bitVIS=no
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5
printf "%s\n" "$do64bitVIS" >&6; }
# Force 64bit on with VIS
if test "$do64bitVIS" = "yes"
then :
do64bit=yes
fi
# Step 0.c: Check if visibility support is available. Do this here so
# that platform specific alternatives can be used below if this fails.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5
printf %s "checking if compiler supports visibility \"hidden\"... " >&6; }
if test ${tcl_cv_cc_visibility_hidden+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
extern __attribute__((__visibility__("hidden"))) void f(void);
void f(void) {}
int
main (void)
{
f();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cc_visibility_hidden=yes
else $as_nop
tcl_cv_cc_visibility_hidden=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5
printf "%s\n" "$tcl_cv_cc_visibility_hidden" >&6; }
if test $tcl_cv_cc_visibility_hidden = yes
then :
printf "%s\n" "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h
printf "%s\n" "#define HAVE_HIDDEN 1" >>confdefs.h
fi
# Step 0.d: Disable -rpath support?
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5
printf %s "checking if rpath support is requested... " >&6; }
# Check whether --enable-rpath was given.
if test ${enable_rpath+y}
then :
enableval=$enable_rpath; doRpath=$enableval
else $as_nop
doRpath=yes
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5
printf "%s\n" "$doRpath" >&6; }
# Step 1: set the variable "system" to hold the name and version number
# for the system.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5
printf %s "checking system version... " >&6; }
if test ${tcl_cv_sys_version+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "${TEA_PLATFORM}" = "windows" ; then
tcl_cv_sys_version=windows
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
tcl_cv_sys_version=NetBSD-Debian
fi
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
printf "%s\n" "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
printf %s "checking for dlopen in -ldl... " >&6; }
if test ${ac_cv_lib_dl_dlopen+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldl $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char dlopen ();
int
main (void)
{
return dlopen ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_dl_dlopen=yes
else $as_nop
ac_cv_lib_dl_dlopen=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; }
if test "x$ac_cv_lib_dl_dlopen" = xyes
then :
have_dl=yes
else $as_nop
have_dl=no
fi
# Require ranlib early so we can override it in special cases below.
|
| ︙ | ︙ | |||
5029 5030 5031 5032 5033 5034 5035 |
# is disabled by the user. [Bug 1016796]
LDFLAGS_ARCH=""
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
| | > > > > > > > > > | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | > | > | | | > | > | | | | > | > | | | > | | 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 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 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 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 5711 5712 5713 5714 5715 5716 5717 5718 5719 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 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 |
# is disabled by the user. [Bug 1016796]
LDFLAGS_ARCH=""
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
if test "$GCC" = yes
then :
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement"
;;
esac
else $as_nop
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
fi
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
set dummy ${ac_tool_prefix}ar; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_AR+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_AR="${ac_tool_prefix}ar"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
AR=$ac_cv_prog_AR
if test -n "$AR"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
printf "%s\n" "$AR" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_AR"; then
ac_ct_AR=$AR
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_AR+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_AR="ar"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_AR=$ac_cv_prog_ac_ct_AR
if test -n "$ac_ct_AR"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
printf "%s\n" "$ac_ct_AR" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_AR" = x; then
AR=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
AR=$ac_ct_AR
fi
else
AR="$ac_cv_prog_AR"
fi
STLIB_LD='${AR} cr'
LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
PLAT_OBJS=""
PLAT_SRCS=""
LDAIX_SRC=""
if test "x${SHLIB_VERSION}" = x
then :
SHLIB_VERSION="1.0"
fi
case $system in
AIX-*)
if test "$GCC" != "yes"
then :
# 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"
SHLIB_CFLAGS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
LD_LIBRARY_PATH_VAR="LIBPATH"
# ldAix No longer needed with use of -bexpall/-brtl
# but some extensions may still reference it
LDAIX_SRC='$(UNIX_DIR)/ldAix'
# 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 with GCC on $system" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS -q64"
LDFLAGS_ARCH="-q64"
RANLIB="${RANLIB} -X64"
AR="${AR} -X64"
SHLIB_LD_FLAGS="-b64"
fi
fi
if test "`uname -m`" = ia64
then :
# AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
# AIX-5 has dl* in libc.so
DL_LIBS=""
if test "$GCC" = yes
then :
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
else $as_nop
CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
fi
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
else $as_nop
if test "$GCC" = yes
then :
SHLIB_LD='${CC} -shared -Wl,-bexpall'
else $as_nop
SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry"
LDFLAGS="$LDFLAGS -brtl"
fi
SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}"
DL_LIBS="-ldl"
|
| ︙ | ︙ | |||
5238 5239 5240 5241 5242 5243 5244 | DL_LIBS="-ldl" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- | | | | > | | < < < | | > | | | | | > | 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 |
DL_LIBS="-ldl"
#-----------------------------------------------------------
# Check for inet_ntoa in -lbind, for BeOS (which also needs
# -lsocket, even if the network functions are in -lnet which
# is always linked to, for compatibility.
#-----------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5
printf %s "checking for inet_ntoa in -lbind... " >&6; }
if test ${ac_cv_lib_bind_inet_ntoa+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lbind $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
main (void)
{
return inet_ntoa ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_bind_inet_ntoa=yes
else $as_nop
ac_cv_lib_bind_inet_ntoa=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5
printf "%s\n" "$ac_cv_lib_bind_inet_ntoa" >&6; }
if test "x$ac_cv_lib_bind_inet_ntoa" = xyes
then :
LIBS="$LIBS -lbind -lsocket"
fi
;;
BSD/OS-2.1*|BSD/OS-3*)
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
|
| ︙ | ︙ | |||
5298 5299 5300 5301 5302 5303 5304 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | | | | > | | | | > | | | | | 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 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 |
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*|MINGW32_*|MSYS_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a'
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5
printf %s "checking for Cygwin version of gcc... " >&6; }
if test ${ac_cv_cygwin+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __CYGWIN__
#error cygwin
#endif
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_cygwin=no
else $as_nop
ac_cv_cygwin=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
printf "%s\n" "$ac_cv_cygwin" >&6; }
if test "$ac_cv_cygwin" = "no"; then
as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5
fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
# The eval makes quoting arguments work.
|
| ︙ | ︙ | |||
5372 5373 5374 5375 5376 5377 5378 |
Haiku*)
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-lroot"
| | | | > | | < < < | | > | | | | | > | | | > | | | | > | | < < < | | > | | | | | > | | > | > | | > | > | > | | | | | | | > | | < < < | | > | | | | | > | | > | 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 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 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 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 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 |
Haiku*)
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-lroot"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5
printf %s "checking for inet_ntoa in -lnetwork... " >&6; }
if test ${ac_cv_lib_network_inet_ntoa+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lnetwork $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char inet_ntoa ();
int
main (void)
{
return inet_ntoa ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_network_inet_ntoa=yes
else $as_nop
ac_cv_lib_network_inet_ntoa=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5
printf "%s\n" "$ac_cv_lib_network_inet_ntoa" >&6; }
if test "x$ac_cv_lib_network_inet_ntoa" = xyes
then :
LIBS="$LIBS -lnetwork"
fi
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
printf "%s\n" "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h
printf "%s\n" "#define _XOPEN_SOURCE 1" >>confdefs.h
LIBS="$LIBS -lxnet" # Use the XOPEN network library
if test "`uname -m`" = ia64
then :
SHLIB_SUFFIX=".so"
else $as_nop
SHLIB_SUFFIX=".sl"
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
printf %s "checking for shl_load in -ldld... " >&6; }
if test ${ac_cv_lib_dld_shl_load+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char shl_load ();
int
main (void)
{
return shl_load ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_dld_shl_load=yes
else $as_nop
ac_cv_lib_dld_shl_load=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
if test "x$ac_cv_lib_dld_shl_load" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = yes
then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="$LDFLAGS -Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
if test "$GCC" = yes
then :
SHLIB_LD='${CC} -shared'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else $as_nop
CFLAGS="$CFLAGS -z"
fi
# Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
#CFLAGS="$CFLAGS +DAportable"
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes"
then :
if test "$GCC" = yes
then :
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
;;
esac
else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS +DD64"
LDFLAGS_ARCH="+DD64"
fi
fi ;;
HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
printf %s "checking for shl_load in -ldld... " >&6; }
if test ${ac_cv_lib_dld_shl_load+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-ldld $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char shl_load ();
int
main (void)
{
return shl_load ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_dld_shl_load=yes
else $as_nop
ac_cv_lib_dld_shl_load=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
if test "x$ac_cv_lib_dld_shl_load" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
if test "$tcl_ok" = yes
then :
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
SHLIB_LD_LIBS=""
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="$LDFLAGS -Wl,-E"
|
| ︙ | ︙ | |||
5600 5601 5602 5603 5604 5605 5606 | DL_LIBS="" case " $LIBOBJS " in *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac | | > | | > | | > | | 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 |
DL_LIBS=""
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes
then :
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
else $as_nop
case $system in
IRIX-6.3)
# Use to build 6.2 compatible binaries on 6.3.
CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS"
;;
*)
|
| ︙ | ︙ | |||
5655 5656 5657 5658 5659 5660 5661 | DL_LIBS="" case " $LIBOBJS " in *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac | | > | | > | > | | | | | > | | > | > | | | > | | | | > | | | | | > | > | > | | | > | | 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 |
DL_LIBS=""
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
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 $as_nop
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS_ARCH="-64"
fi
fi
;;
Linux*|GNU*|NetBSD-Debian)
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"
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "`uname -m`" = "alpha"
then :
CFLAGS="$CFLAGS -mieee"
fi
if test $do64bit = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5
printf %s "checking if compiler accepts -m64 flag... " >&6; }
if test ${tcl_cv_cc_m64+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cc_m64=yes
else $as_nop
tcl_cv_cc_m64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5
printf "%s\n" "$tcl_cv_cc_m64" >&6; }
if test $tcl_cv_cc_m64 = yes
then :
CFLAGS="$CFLAGS -m64"
do64bit_ok=yes
fi
fi
# The combo of gcc + glibc has a bug related to inlining of
# functions like strtol()/strtoul(). The -fno-builtin flag should address
# this problem but it does not work. The -fno-inline flag is kind
# of overkill but it works. Disable inlining only when one of the
# files in compat/*.c is being linked in.
if test x"${USE_COMPAT}" != x
then :
CFLAGS="$CFLAGS -fno-inline"
fi
;;
Lynx*)
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
|
| ︙ | ︙ | |||
5806 5807 5808 5809 5810 5811 5812 |
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
| | > | < | > | | | 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 |
# NetBSD has ELF and can use 'cc -shared' to build shared libs
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
|
| ︙ | ︙ | |||
5855 5856 5857 5858 5859 5860 5861 |
# -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`"
CFLAGS="`echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`"
| | > | | | > | | | | > | | | | | > | | | > | | | | > | | | | | > | | | | > | | | > | | | | > | | | | | > | | | > | | | | > | | | | | > | > | | | | | > | | | | > | | | > | | | > | | > | | | > | | | > | | | > | | | > | | | | > | | | | | > | | | > | | > | | > | | > | < | > | | | | > | | | | > | > | > | > | | | | | > | | | > | > | | | | | | | > | | | | > | | | | > < | | | | > | > | > | | > | | > | | 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 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 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 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 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 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 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 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 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 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 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 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 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 |
# -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`"
CFLAGS="`echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`"
if test $do64bit = yes
then :
case `arch` in
ppc)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5
printf %s "checking if compiler accepts -arch ppc64 flag... " >&6; }
if test ${tcl_cv_cc_arch_ppc64+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cc_arch_ppc64=yes
else $as_nop
tcl_cv_cc_arch_ppc64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5
printf "%s\n" "$tcl_cv_cc_arch_ppc64" >&6; }
if test $tcl_cv_cc_arch_ppc64 = yes
then :
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
do64bit_ok=yes
fi;;
i386)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5
printf %s "checking if compiler accepts -arch x86_64 flag... " >&6; }
if test ${tcl_cv_cc_arch_x86_64+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch x86_64"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_cc_arch_x86_64=yes
else $as_nop
tcl_cv_cc_arch_x86_64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5
printf "%s\n" "$tcl_cv_cc_arch_x86_64" >&6; }
if test $tcl_cv_cc_arch_x86_64 = yes
then :
CFLAGS="$CFLAGS -arch x86_64"
do64bit_ok=yes
fi;;
*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5
printf "%s\n" "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};;
esac
else $as_nop
# Check for combined 32-bit and 64-bit fat build
if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \
&& echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '
then :
fat_32_64=yes
fi
fi
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -single_module flag" >&5
printf %s "checking if ld accepts -single_module flag... " >&6; }
if test ${tcl_cv_ld_single_module+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
int i;
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_ld_single_module=yes
else $as_nop
tcl_cv_ld_single_module=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_single_module" >&5
printf "%s\n" "$tcl_cv_ld_single_module" >&6; }
if test $tcl_cv_ld_single_module = yes
then :
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
fi
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}
then :
printf %s "(cached) " >&6
else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
int i;
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_ld_search_paths_first=yes
else $as_nop
tcl_cv_ld_search_paths_first=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5
printf "%s\n" "$tcl_cv_ld_search_paths_first" >&6; }
if test $tcl_cv_ld_search_paths_first = yes
then :
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
fi
if test "$tcl_cv_cc_visibility_hidden" != yes
then :
printf "%s\n" "#define MODULE_SCOPE __private_extern__" >>confdefs.h
tcl_cv_cc_visibility_hidden=yes
fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
printf "%s\n" "#define MAC_OSX_TCL 1" >>confdefs.h
PLAT_OBJS='${MAC_OSX_OBJS}'
PLAT_SRCS='${MAC_OSX_SRCS}'
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use CoreFoundation" >&5
printf %s "checking whether to use CoreFoundation... " >&6; }
# Check whether --enable-corefoundation was given.
if test ${enable_corefoundation+y}
then :
enableval=$enable_corefoundation; tcl_corefoundation=$enableval
else $as_nop
tcl_corefoundation=yes
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_corefoundation" >&5
printf "%s\n" "$tcl_corefoundation" >&6; }
if test $tcl_corefoundation = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CoreFoundation.framework" >&5
printf %s "checking for CoreFoundation.framework... " >&6; }
if test ${tcl_cv_lib_corefoundation+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_libs=$LIBS
if test "$fat_32_64" = yes
then :
for v in CFLAGS CPPFLAGS LDFLAGS; do
# On Tiger there is no 64-bit CF, so remove 64-bit
# archs from CFLAGS et al. while testing for
# presence of CF. 64-bit CF is disabled in
# tclUnixPort.h if necessary.
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"'
done
fi
LIBS="$LIBS -framework CoreFoundation"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <CoreFoundation/CoreFoundation.h>
int
main (void)
{
CFBundleRef b = CFBundleGetMainBundle();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_lib_corefoundation=yes
else $as_nop
tcl_cv_lib_corefoundation=no
fi
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
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
then :
LIBS="$LIBS -framework CoreFoundation"
printf "%s\n" "#define HAVE_COREFOUNDATION 1" >>confdefs.h
else $as_nop
tcl_corefoundation=no
fi
if test "$fat_32_64" = yes -a $tcl_corefoundation = yes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit CoreFoundation" >&5
printf %s "checking for 64-bit CoreFoundation... " >&6; }
if test ${tcl_cv_lib_corefoundation_64+y}
then :
printf %s "(cached) " >&6
else $as_nop
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"'
done
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <CoreFoundation/CoreFoundation.h>
int
main (void)
{
CFBundleRef b = CFBundleGetMainBundle();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_lib_corefoundation_64=yes
else $as_nop
tcl_cv_lib_corefoundation_64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation_64" >&5
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='ld -shared -expect_unresolved "*"'
else $as_nop
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes
then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes
then :
CFLAGS="$CFLAGS -mieee"
else $as_nop
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
if test "$GCC" = yes
then :
LIBS="$LIBS -lpthread -lmach -lexc"
else $as_nop
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
fi
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SCO_SV-3.2*)
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
if test "$GCC" = yes
then :
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
else $as_nop
SHLIB_CFLAGS="-Kpic -belf"
LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
fi
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SunOS-5.[0-6])
# Careful to not let 5.10+ fall into this case
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
SHLIB_CFLAGS="-KPIC"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
if test "$GCC" = yes
then :
SHLIB_LD='${CC} -shared'
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else $as_nop
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
fi
;;
SunOS-5*)
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
SHLIB_CFLAGS="-KPIC"
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = yes
then :
arch=`isainfo`
if test "$arch" = "sparcv9 sparc"
then :
if test "$GCC" = yes
then :
if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
else $as_nop
do64bit_ok=yes
CFLAGS="$CFLAGS -m64 -mcpu=v9"
LDFLAGS="$LDFLAGS -m64 -mcpu=v9"
SHLIB_CFLAGS="-fPIC"
fi
else $as_nop
do64bit_ok=yes
if test "$do64bitVIS" = yes
then :
CFLAGS="$CFLAGS -xarch=v9a"
LDFLAGS_ARCH="-xarch=v9a"
else $as_nop
CFLAGS="$CFLAGS -xarch=v9"
LDFLAGS_ARCH="-xarch=v9"
fi
# Solaris 64 uses this as well
#LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64"
fi
else $as_nop
if test "$arch" = "amd64 i386"
then :
if test "$GCC" = yes
then :
case $system in
SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*)
do64bit_ok=yes
CFLAGS="$CFLAGS -m64"
LDFLAGS="$LDFLAGS -m64";;
*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};;
esac
else $as_nop
do64bit_ok=yes
case $system in
SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*)
CFLAGS="$CFLAGS -m64"
LDFLAGS="$LDFLAGS -m64";;
*)
CFLAGS="$CFLAGS -xarch=amd64"
LDFLAGS="$LDFLAGS -xarch=amd64";;
esac
fi
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5
printf "%s\n" "$as_me: WARNING: 64bit mode not supported for $arch" >&2;}
fi
fi
fi
#--------------------------------------------------------------------
# On Solaris 5.x i386 with the sunpro compiler we need to link
# with sunmath to get floating point rounding control
#--------------------------------------------------------------------
if test "$GCC" = yes
then :
use_sunmath=no
else $as_nop
arch=`isainfo`
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use -lsunmath for fp rounding control" >&5
printf %s "checking whether to use -lsunmath for fp rounding control... " >&6; }
if test "$arch" = "amd64 i386" -o "$arch" = "i386"
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
MATH_LIBS="-lsunmath $MATH_LIBS"
ac_fn_c_check_header_compile "$LINENO" "sunmath.h" "ac_cv_header_sunmath_h" "$ac_includes_default"
if test "x$ac_cv_header_sunmath_h" = xyes
then :
fi
use_sunmath=yes
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
use_sunmath=no
fi
fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
if test "$GCC" = yes
then :
SHLIB_LD='${CC} -shared'
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "$do64bit_ok" = yes
then :
if test "$arch" = "sparcv9 sparc"
then :
# We need to specify -static-libgcc or we need to
# add the path to the sparv9 libgcc.
SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc"
# for finding sparcv9 libgcc, get the regular libgcc
# path, remove so name and append 'sparcv9'
#v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
#CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
else $as_nop
if test "$arch" = "amd64 i386"
then :
SHLIB_LD="$SHLIB_LD -m64 -static-libgcc"
fi
fi
fi
else $as_nop
if test "$use_sunmath" = yes
then :
textmode=textoff
else $as_nop
textmode=text
fi
case $system in
SunOS-5.[1-9][0-9]*|SunOS-5.[7-9])
SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";;
*)
SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";;
|
| ︙ | ︙ | |||
6451 6452 6453 6454 6455 6456 6457 |
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
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.
| | | | > | | | | > | | | | | > | > | | | > | | > | | > | > | | | | > | > > > | | | > | | > | > | > | > | | | > | | > | | > | | | > | | | | > | | | | | | | > | < | 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 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 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 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 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 |
SHLIB_LD='${CC} -G'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
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.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5
printf %s "checking for ld accepts -Bexport flag... " >&6; }
if test ${tcl_cv_ld_Bexport+y}
then :
printf %s "(cached) " >&6
else $as_nop
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-Bexport"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
int i;
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_ld_Bexport=yes
else $as_nop
tcl_cv_ld_Bexport=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LDFLAGS=$hold_ldflags
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 :
LDFLAGS="$LDFLAGS -Wl,-Bexport"
fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
if test "$do64bit" = yes -a "$do64bit_ok" = no
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
printf "%s\n" "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;}
fi
if test "$do64bit" = yes -a "$do64bit_ok" = yes
then :
printf "%s\n" "#define TCL_CFG_DO64BIT 1" >>confdefs.h
fi
# Step 4: disable dynamic loading if requested via a command-line switch.
# Check whether --enable-load was given.
if test ${enable_load+y}
then :
enableval=$enable_load; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = no
then :
DL_OBJS=""
fi
if test "x$DL_OBJS" != x
then :
BUILD_DLTEST="\$(DLTEST_TARGETS)"
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5
printf "%s\n" "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;}
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS_ORIG"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
BUILD_DLTEST=""
fi
LDFLAGS="$LDFLAGS $LDFLAGS_ARCH"
# If we're running gcc, then change the C flags for compiling shared
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes
then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*|MINGW32_*|MSYS_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac
fi
if test "$tcl_cv_cc_visibility_hidden" != yes
then :
printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h
fi
if test "$SHARED_LIB_SUFFIX" = ""
then :
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
fi
if test "$UNSHARED_LIB_SUFFIX" = ""
then :
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)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
else $as_nop
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
fi
else $as_nop
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
if test "$RANLIB" = ""
then :
MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
else $as_nop
MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
fi
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
fi
# Stub lib does not depend on shared/static configuration
if test "$RANLIB" = ""
then :
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
else $as_nop
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
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.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
printf %s "checking for cast to union support... " >&6; }
if test ${tcl_cv_cast_to_union+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
union foo { int i; double d; };
union foo f = (union foo) (int) 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_cast_to_union=yes
else $as_nop
tcl_cv_cast_to_union=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
printf "%s\n" "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
if test "x$ac_cv_header_stdbool_h" = xyes
then :
printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h
fi
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
# would use TCL_DL_LIBS instead of TCL_LIBS.
|
| ︙ | ︙ | |||
6705 6706 6707 6708 6709 6710 6711 |
| < | < | | | > | | | | | | | | | | | | | | | | | | > | | | | > | | | > | | | | | > | | | | > | | | > | | | | | > | | | | > | | | > | | | | | | | | | | | > | | | | > | | | | > | | | | < | < | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | > | | > | > | > | | < < < | | | > | | | | > | | | | | | | | | | > | | | > | 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 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 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 7575 7576 7577 7578 7579 7580 7581 7582 7583 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 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 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 |
printf "%s\n" "#define TCL_SHLIB_EXT \"${SHLIB_SUFFIX}\"" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
printf %s "checking for build with symbols... " >&6; }
# Check whether --enable-symbols was given.
if test ${enable_symbols+y}
then :
enableval=$enable_symbols; tcl_ok=$enableval
else $as_nop
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
printf "%s\n" "#define NDEBUG 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
printf "%s\n" "yes (standard debugging)" >&6; }
fi
fi
if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h
fi
if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
printf "%s\n" "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
printf "%s\n" "#define TCL_COMPILE_STATS 1" >>confdefs.h
fi
if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
if test "$tcl_ok" = "all"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
printf "%s\n" "enabled symbols mem compile debugging" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
printf "%s\n" "enabled $tcl_ok debugging" >&6; }
fi
fi
printf "%s\n" "#define MP_PREC 4" >>confdefs.h
#--------------------------------------------------------------------
# Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5
printf %s "checking for required early compiler flags... " >&6; }
tcl_flags=""
if test ${tcl_cv_flag__isoc99_source+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
int
main (void)
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__isoc99_source=no
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int
main (void)
{
char *p = (char *)strtoll; char *q = (char *)strtoull;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__isoc99_source=yes
else $as_nop
tcl_cv_flag__isoc99_source=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then
printf "%s\n" "#define _ISOC99_SOURCE 1" >>confdefs.h
tcl_flags="$tcl_flags _ISOC99_SOURCE"
fi
if test ${tcl_cv_flag__largefile64_source+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/stat.h>
int
main (void)
{
struct stat64 buf; int i = stat64("/", &buf);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__largefile64_source=no
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int
main (void)
{
struct stat64 buf; int i = stat64("/", &buf);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__largefile64_source=yes
else $as_nop
tcl_cv_flag__largefile64_source=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then
printf "%s\n" "#define _LARGEFILE64_SOURCE 1" >>confdefs.h
tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
fi
if test ${tcl_cv_flag__largefile_source64+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/stat.h>
int
main (void)
{
char *p = (char *)open64;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__largefile_source64=no
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define _LARGEFILE_SOURCE64 1
#include <sys/stat.h>
int
main (void)
{
char *p = (char *)open64;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_flag__largefile_source64=yes
else $as_nop
tcl_cv_flag__largefile_source64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then
printf "%s\n" "#define _LARGEFILE_SOURCE64 1" >>confdefs.h
tcl_flags="$tcl_flags _LARGEFILE_SOURCE64"
fi
if test "x${tcl_flags}" = "x" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5
printf "%s\n" "none" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5
printf "%s\n" "${tcl_flags}" >&6; }
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit integer type" >&5
printf %s "checking for 64-bit integer type... " >&6; }
if test ${tcl_cv_type_64bit+y}
then :
printf %s "(cached) " >&6
else $as_nop
tcl_cv_type_64bit=none
# See if the compiler knows natively about __int64
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
__int64 value = (__int64) 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_type_64bit=__int64
else $as_nop
tcl_type_64bit="long long"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
# 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(${tcl_type_64bit})==sizeof(long)): ;
}
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_type_64bit=${tcl_type_64bit}
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test "${tcl_cv_type_64bit}" = none ; then
printf "%s\n" "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
else
printf "%s\n" "#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_cv_type_64bit}" >&5
printf "%s\n" "${tcl_cv_type_64bit}" >&6; }
# Now check for auxiliary declarations
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5
printf %s "checking for struct dirent64... " >&6; }
if test ${tcl_cv_struct_dirent64+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <dirent.h>
int
main (void)
{
struct dirent64 p;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_struct_dirent64=yes
else $as_nop
tcl_cv_struct_dirent64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
printf "%s\n" "$tcl_cv_struct_dirent64" >&6; }
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5
printf %s "checking for DIR64... " >&6; }
if test ${tcl_cv_DIR64+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* 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
else $as_nop
tcl_cv_DIR64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5
printf "%s\n" "$tcl_cv_DIR64" >&6; }
if test "x${tcl_cv_DIR64}" = "xyes" ; then
printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct stat64" >&5
printf %s "checking for struct stat64... " >&6; }
if test ${tcl_cv_struct_stat64+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/stat.h>
int
main (void)
{
struct stat64 p;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_struct_stat64=yes
else $as_nop
tcl_cv_struct_stat64=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_stat64" >&5
printf "%s\n" "$tcl_cv_struct_stat64" >&6; }
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
printf "%s\n" "#define HAVE_STRUCT_STAT64 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "open64" "ac_cv_func_open64"
if test "x$ac_cv_func_open64" = xyes
then :
printf "%s\n" "#define HAVE_OPEN64 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "lseek64" "ac_cv_func_lseek64"
if test "x$ac_cv_func_lseek64" = xyes
then :
printf "%s\n" "#define HAVE_LSEEK64 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5
printf %s "checking for off64_t... " >&6; }
if test ${tcl_cv_type_off64_t+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
int
main (void)
{
off64_t offset;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_type_off64_t=yes
else $as_nop
tcl_cv_type_off64_t=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
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
printf "%s\n" "no" >&6; }
fi
fi
#--------------------------------------------------------------------
# Check endianness because we can optimize comparisons of
# Tcl_UniChar strings to memcmp on big-endian systems.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5
printf %s "checking whether byte ordering is bigendian... " >&6; }
if test ${ac_cv_c_bigendian+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_c_bigendian=unknown
# See if we're dealing with a universal compiler.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef __APPLE_CC__
not a universal capable compiler
#endif
typedef int dummy;
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
# Check for potential -arch flags. It is not universal unless
# there are at least two -arch flags with different values.
ac_arch=
ac_prev=
for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do
if test -n "$ac_prev"; then
|
| ︙ | ︙ | |||
7200 7201 7202 7203 7204 7205 7206 |
esac
ac_prev=
elif test "x$ac_word" = "x-arch"; then
ac_prev=arch
fi
done
fi
| | | | > | | > | | | | | > | | > | | | | > | | | | | | > | | | | > | | | | | > | | < > | < | | < > | > | | < | > | | < | > | | < | > | | < | > | | | > | | | > | | | > | | | > | | > | | | > | | < > | > < | < | | > < | < | | > < | < | | > < | < | | | > | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | | | | > | < | < | > | | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | > | < | < | > | | > | | | > | | | | > | | | | | | | | > | | | | > | | | | | | < < | | < > | < < < < < | | < > | < < < < < | | < > | < < < | | | > | | | | > | | | | | | | > | | | > | | | | | | | | | | | | | | | < | < | | | < > | < | | < | | | | | | > | < | > | | | | | | < | | < > | < < < < > | < < < < < < < | < | < > | | < | < > > | > | < < < < | < | | | | | < | < < < | < < < | | | > | | | | > | | | | | | | | > | | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | > < | < | > < | < | > < | < | > | | | | | > | | | > | | | 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 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 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 8248 8249 8250 8251 8252 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 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 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 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 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 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 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 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 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 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 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 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 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 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 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 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 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 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 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 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 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 |
esac
ac_prev=
elif test "x$ac_word" = "x-arch"; then
ac_prev=arch
fi
done
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
if test $ac_cv_c_bigendian = unknown; then
# See if sys/param.h defines the BYTE_ORDER macro.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <sys/param.h>
int
main (void)
{
#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \
&& defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \
&& LITTLE_ENDIAN)
bogus endian macros
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
# It does; now see whether it defined to BIG_ENDIAN or not.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <sys/param.h>
int
main (void)
{
#if BYTE_ORDER != BIG_ENDIAN
not big endian
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_c_bigendian=yes
else $as_nop
ac_cv_c_bigendian=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test $ac_cv_c_bigendian = unknown; then
# See if <limits.h> defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris).
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
int
main (void)
{
#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN)
bogus endian macros
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
# It does; now see whether it defined to _BIG_ENDIAN or not.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
int
main (void)
{
#ifndef _BIG_ENDIAN
not big endian
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_c_bigendian=yes
else $as_nop
ac_cv_c_bigendian=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
if test $ac_cv_c_bigendian = unknown; then
# Compile a test program.
if test "$cross_compiling" = yes
then :
# Try to guess by grepping values from an object file.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
unsigned short int ascii_mm[] =
{ 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
unsigned short int ascii_ii[] =
{ 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
int use_ascii (int i) {
return ascii_mm[i] + ascii_ii[i];
}
unsigned short int ebcdic_ii[] =
{ 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 };
unsigned short int ebcdic_mm[] =
{ 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 };
int use_ebcdic (int i) {
return ebcdic_mm[i] + ebcdic_ii[i];
}
extern int foo;
int
main (void)
{
return use_ascii (foo) == use_ebcdic (foo);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then
ac_cv_c_bigendian=yes
fi
if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then
if test "$ac_cv_c_bigendian" = unknown; then
ac_cv_c_bigendian=no
else
# finding both strings is unlikely to happen, but who knows?
ac_cv_c_bigendian=unknown
fi
fi
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
main (void)
{
/* Are we little or big endian? From Harbison&Steele. */
union
{
long int l;
char c[sizeof (long int)];
} u;
u.l = 1;
return u.c[sizeof (long int) - 1] == 1;
;
return 0;
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
ac_cv_c_bigendian=no
else $as_nop
ac_cv_c_bigendian=yes
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5
printf "%s\n" "$ac_cv_c_bigendian" >&6; }
case $ac_cv_c_bigendian in #(
yes)
printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h
;; #(
no)
;; #(
universal)
printf "%s\n" "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h
;; #(
*)
as_fn_error $? "unknown endianness
presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;;
esac
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX library procedures, or
# set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------
# Check if Posix compliant getcwd exists, if not we'll use getwd.
for ac_func in getcwd
do :
ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd"
if test "x$ac_cv_func_getcwd" = xyes
then :
printf "%s\n" "#define HAVE_GETCWD 1" >>confdefs.h
else $as_nop
printf "%s\n" "#define USEGETWD 1" >>confdefs.h
fi
done
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?
ac_fn_c_check_func "$LINENO" "mkstemp" "ac_cv_func_mkstemp"
if test "x$ac_cv_func_mkstemp" = xyes
then :
printf "%s\n" "#define HAVE_MKSTEMP 1" >>confdefs.h
else $as_nop
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
fi
ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir"
if test "x$ac_cv_func_opendir" = xyes
then :
printf "%s\n" "#define HAVE_OPENDIR 1" >>confdefs.h
else $as_nop
case " $LIBOBJS " in
*" opendir.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS opendir.$ac_objext"
;;
esac
fi
ac_fn_c_check_func "$LINENO" "strtol" "ac_cv_func_strtol"
if test "x$ac_cv_func_strtol" = xyes
then :
printf "%s\n" "#define HAVE_STRTOL 1" >>confdefs.h
else $as_nop
case " $LIBOBJS " in
*" strtol.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS strtol.$ac_objext"
;;
esac
fi
ac_fn_c_check_func "$LINENO" "waitpid" "ac_cv_func_waitpid"
if test "x$ac_cv_func_waitpid" = xyes
then :
printf "%s\n" "#define HAVE_WAITPID 1" >>confdefs.h
else $as_nop
case " $LIBOBJS " in
*" waitpid.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS waitpid.$ac_objext"
;;
esac
fi
ac_fn_c_check_func "$LINENO" "strerror" "ac_cv_func_strerror"
if test "x$ac_cv_func_strerror" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_STRERROR 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd"
if test "x$ac_cv_func_getwd" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_GETWD 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "wait3" "ac_cv_func_wait3"
if test "x$ac_cv_func_wait3" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_WAIT3 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname"
if test "x$ac_cv_func_uname" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_UNAME 1" >>confdefs.h
fi
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print $1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath"
if test "x$ac_cv_func_realpath" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_REALPATH 1" >>confdefs.h
fi
NEED_FAKE_RFC2553=0
for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror
do :
as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | $as_tr_sh`
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
if eval test \"x\$"$as_ac_var"\" = x"yes"
then :
cat >>confdefs.h <<_ACEOF
#define `printf "%s\n" "HAVE_$ac_func" | $as_tr_cpp` 1
_ACEOF
else $as_nop
NEED_FAKE_RFC2553=1
fi
done
ac_fn_c_check_type "$LINENO" "struct addrinfo" "ac_cv_type_struct_addrinfo" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
"
if test "x$ac_cv_type_struct_addrinfo" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_ADDRINFO 1" >>confdefs.h
else $as_nop
NEED_FAKE_RFC2553=1
fi
ac_fn_c_check_type "$LINENO" "struct in6_addr" "ac_cv_type_struct_in6_addr" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
"
if test "x$ac_cv_type_struct_in6_addr" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_IN6_ADDR 1" >>confdefs.h
else $as_nop
NEED_FAKE_RFC2553=1
fi
ac_fn_c_check_type "$LINENO" "struct sockaddr_in6" "ac_cv_type_struct_sockaddr_in6" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
"
if test "x$ac_cv_type_struct_sockaddr_in6" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_IN6 1" >>confdefs.h
else $as_nop
NEED_FAKE_RFC2553=1
fi
ac_fn_c_check_type "$LINENO" "struct sockaddr_storage" "ac_cv_type_struct_sockaddr_storage" "
#include <sys/types.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <netdb.h>
"
if test "x$ac_cv_type_struct_sockaddr_storage" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_STORAGE 1" >>confdefs.h
else $as_nop
NEED_FAKE_RFC2553=1
fi
if test "x$NEED_FAKE_RFC2553" = "x1"; then
printf "%s\n" "#define NEED_FAKE_RFC2553 1" >>confdefs.h
case " $LIBOBJS " in
*" fake-rfc2553.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext"
;;
esac
ac_fn_c_check_func "$LINENO" "strlcpy" "ac_cv_func_strlcpy"
if test "x$ac_cv_func_strlcpy" = xyes
then :
fi
fi
#--------------------------------------------------------------------
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r"
if test "x$ac_cv_func_getpwuid_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5
printf %s "checking for getpwuid_r with 5 args... " >&6; }
if test ${tcl_cv_api_getpwuid_r_5+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
main (void)
{
uid_t uid;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwuid_r(uid, &pw, buf, buflen, &pwp);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getpwuid_r_5=yes
else $as_nop
tcl_cv_api_getpwuid_r_5=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_5" >&5
printf "%s\n" "$tcl_cv_api_getpwuid_r_5" >&6; }
tcl_ok=$tcl_cv_api_getpwuid_r_5
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWUID_R_5 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 4 args" >&5
printf %s "checking for getpwuid_r with 4 args... " >&6; }
if test ${tcl_cv_api_getpwuid_r_4+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
main (void)
{
uid_t uid;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(uid, &pw, buf, buflen);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getpwuid_r_4=yes
else $as_nop
tcl_cv_api_getpwuid_r_4=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_4" >&5
printf "%s\n" "$tcl_cv_api_getpwuid_r_4" >&6; }
tcl_ok=$tcl_cv_api_getpwuid_r_4
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWUID_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWUID_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r"
if test "x$ac_cv_func_getpwnam_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5
printf %s "checking for getpwnam_r with 5 args... " >&6; }
if test ${tcl_cv_api_getpwnam_r_5+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
main (void)
{
char *name;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwnam_r(name, &pw, buf, buflen, &pwp);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getpwnam_r_5=yes
else $as_nop
tcl_cv_api_getpwnam_r_5=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_5" >&5
printf "%s\n" "$tcl_cv_api_getpwnam_r_5" >&6; }
tcl_ok=$tcl_cv_api_getpwnam_r_5
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWNAM_R_5 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 4 args" >&5
printf %s "checking for getpwnam_r with 4 args... " >&6; }
if test ${tcl_cv_api_getpwnam_r_4+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <pwd.h>
int
main (void)
{
char *name;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(name, &pw, buf, buflen);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getpwnam_r_4=yes
else $as_nop
tcl_cv_api_getpwnam_r_4=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_4" >&5
printf "%s\n" "$tcl_cv_api_getpwnam_r_4" >&6; }
tcl_ok=$tcl_cv_api_getpwnam_r_4
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWNAM_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETPWNAM_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getgrgid_r" "ac_cv_func_getgrgid_r"
if test "x$ac_cv_func_getgrgid_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5
printf %s "checking for getgrgid_r with 5 args... " >&6; }
if test ${tcl_cv_api_getgrgid_r_5+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
main (void)
{
gid_t gid;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrgid_r(gid, &gr, buf, buflen, &grp);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getgrgid_r_5=yes
else $as_nop
tcl_cv_api_getgrgid_r_5=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_5" >&5
printf "%s\n" "$tcl_cv_api_getgrgid_r_5" >&6; }
tcl_ok=$tcl_cv_api_getgrgid_r_5
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRGID_R_5 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 4 args" >&5
printf %s "checking for getgrgid_r with 4 args... " >&6; }
if test ${tcl_cv_api_getgrgid_r_4+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
main (void)
{
gid_t gid;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrgid_r(gid, &gr, buf, buflen);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getgrgid_r_4=yes
else $as_nop
tcl_cv_api_getgrgid_r_4=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_4" >&5
printf "%s\n" "$tcl_cv_api_getgrgid_r_4" >&6; }
tcl_ok=$tcl_cv_api_getgrgid_r_4
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRGID_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRGID_R 1" >>confdefs.h
fi
fi
ac_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r"
if test "x$ac_cv_func_getgrnam_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5
printf %s "checking for getgrnam_r with 5 args... " >&6; }
if test ${tcl_cv_api_getgrnam_r_5+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
main (void)
{
char *name;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrnam_r(name, &gr, buf, buflen, &grp);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getgrnam_r_5=yes
else $as_nop
tcl_cv_api_getgrnam_r_5=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_5" >&5
printf "%s\n" "$tcl_cv_api_getgrnam_r_5" >&6; }
tcl_ok=$tcl_cv_api_getgrnam_r_5
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRNAM_R_5 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 4 args" >&5
printf %s "checking for getgrnam_r with 4 args... " >&6; }
if test ${tcl_cv_api_getgrnam_r_4+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <grp.h>
int
main (void)
{
char *name;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrnam_r(name, &gr, buf, buflen);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_getgrnam_r_4=yes
else $as_nop
tcl_cv_api_getgrnam_r_4=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_4" >&5
printf "%s\n" "$tcl_cv_api_getgrnam_r_4" >&6; }
tcl_ok=$tcl_cv_api_getgrnam_r_4
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRNAM_R_4 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETGRNAM_R 1" >>confdefs.h
fi
fi
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print $1}'`" -gt 5; then
# Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
elif test "`uname -s`" = "HP-UX" && \
test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
# Starting with HPUX 11.00 (we believe), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
else
# Avoids picking hidden internal symbol from libc
ac_fn_c_check_decl "$LINENO" "gethostbyname_r" "ac_cv_have_decl_gethostbyname_r" "#include <netdb.h>
"
if test "x$ac_cv_have_decl_gethostbyname_r" = xyes
then :
ac_have_decl=1
else $as_nop
ac_have_decl=0
fi
printf "%s\n" "#define HAVE_DECL_GETHOSTBYNAME_R $ac_have_decl" >>confdefs.h
if test $ac_have_decl = 1
then :
tcl_cv_api_gethostbyname_r=yes
else $as_nop
tcl_cv_api_gethostbyname_r=no
fi
if test "$tcl_cv_api_gethostbyname_r" = yes; then
ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r"
if test "x$ac_cv_func_gethostbyname_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5
printf %s "checking for gethostbyname_r with 6 args... " >&6; }
if test ${tcl_cv_api_gethostbyname_r_6+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
main (void)
{
char *name;
struct hostent *he, *res;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &res, &h_errnop);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_gethostbyname_r_6=yes
else $as_nop
tcl_cv_api_gethostbyname_r_6=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_6" >&5
printf "%s\n" "$tcl_cv_api_gethostbyname_r_6" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_6
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_6 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 5 args" >&5
printf %s "checking for gethostbyname_r with 5 args... " >&6; }
if test ${tcl_cv_api_gethostbyname_r_5+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
main (void)
{
char *name;
struct hostent *he;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &h_errnop);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_gethostbyname_r_5=yes
else $as_nop
tcl_cv_api_gethostbyname_r_5=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_5" >&5
printf "%s\n" "$tcl_cv_api_gethostbyname_r_5" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_5
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_5 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 3 args" >&5
printf %s "checking for gethostbyname_r with 3 args... " >&6; }
if test ${tcl_cv_api_gethostbyname_r_3+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
main (void)
{
char *name;
struct hostent *he;
struct hostent_data data;
(void) gethostbyname_r(name, he, &data);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_gethostbyname_r_3=yes
else $as_nop
tcl_cv_api_gethostbyname_r_3=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyname_r_3" >&5
printf "%s\n" "$tcl_cv_api_gethostbyname_r_3" >&6; }
tcl_ok=$tcl_cv_api_gethostbyname_r_3
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYNAME_R_3 1" >>confdefs.h
fi
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
fi
fi
# Avoids picking hidden internal symbol from libc
ac_fn_c_check_decl "$LINENO" "gethostbyaddr_r" "ac_cv_have_decl_gethostbyaddr_r" "#include <netdb.h>
"
if test "x$ac_cv_have_decl_gethostbyaddr_r" = xyes
then :
ac_have_decl=1
else $as_nop
ac_have_decl=0
fi
printf "%s\n" "#define HAVE_DECL_GETHOSTBYADDR_R $ac_have_decl" >>confdefs.h
if test $ac_have_decl = 1
then :
tcl_cv_api_gethostbyaddr_r=yes
else $as_nop
tcl_cv_api_gethostbyaddr_r=no
fi
if test "$tcl_cv_api_gethostbyaddr_r" = yes; then
ac_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r"
if test "x$ac_cv_func_gethostbyaddr_r" = xyes
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5
printf %s "checking for gethostbyaddr_r with 7 args... " >&6; }
if test ${tcl_cv_api_gethostbyaddr_r_7+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
main (void)
{
char *addr;
int length;
int type;
struct hostent *result;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&h_errnop);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_gethostbyaddr_r_7=yes
else $as_nop
tcl_cv_api_gethostbyaddr_r_7=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_7" >&5
printf "%s\n" "$tcl_cv_api_gethostbyaddr_r_7" >&6; }
tcl_ok=$tcl_cv_api_gethostbyaddr_r_7
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYADDR_R_7 1" >>confdefs.h
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 8 args" >&5
printf %s "checking for gethostbyaddr_r with 8 args... " >&6; }
if test ${tcl_cv_api_gethostbyaddr_r_8+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <netdb.h>
int
main (void)
{
char *addr;
int length;
int type;
struct hostent *result, *resultp;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&resultp, &h_errnop);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_api_gethostbyaddr_r_8=yes
else $as_nop
tcl_cv_api_gethostbyaddr_r_8=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_gethostbyaddr_r_8" >&5
printf "%s\n" "$tcl_cv_api_gethostbyaddr_r_8" >&6; }
tcl_ok=$tcl_cv_api_gethostbyaddr_r_8
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYADDR_R_8 1" >>confdefs.h
fi
fi
if test "$tcl_ok" = yes; then
printf "%s\n" "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
fi
fi
fi
#---------------------------------------------------------------------------
# Check for serial port interface.
#
# termios.h is present on all POSIX systems.
# sys/ioctl.h is almost always present, though what it contains
# is system-specific.
# sys/modem.h is needed on HP-UX.
#---------------------------------------------------------------------------
ac_fn_c_check_header_compile "$LINENO" "termios.h" "ac_cv_header_termios_h" "$ac_includes_default"
if test "x$ac_cv_header_termios_h" = xyes
then :
printf "%s\n" "#define HAVE_TERMIOS_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_ioctl_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "sys/modem.h" "ac_cv_header_sys_modem_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_modem_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_MODEM_H 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Include sys/select.h if it exists and if it supplies things
# that appear to be useful and aren't already in sys/types.h.
# This appears to be true only on the RS/6000 under AIX. Some
# systems like OSF/1 have a sys/select.h that's of no use, and
# other systems like SCO UNIX have a sys/select.h that's
# pernicious. If "fd_set" isn't defined anywhere then set a
# special flag.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fd_set in sys/types" >&5
printf %s "checking for fd_set in sys/types... " >&6; }
if test ${tcl_cv_type_fd_set+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
int
main (void)
{
fd_set readMask, writeMask;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_type_fd_set=yes
else $as_nop
tcl_cv_type_fd_set=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_fd_set" >&5
printf "%s\n" "$tcl_cv_type_fd_set" >&6; }
tcl_ok=$tcl_cv_type_fd_set
if test $tcl_ok = no; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fd_mask in sys/select" >&5
printf %s "checking for fd_mask in sys/select... " >&6; }
if test ${tcl_cv_grep_fd_mask+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/select.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "fd_mask" >/dev/null 2>&1
then :
tcl_cv_grep_fd_mask=present
else $as_nop
tcl_cv_grep_fd_mask=missing
fi
rm -rf conftest*
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_fd_mask" >&5
printf "%s\n" "$tcl_cv_grep_fd_mask" >&6; }
if test $tcl_cv_grep_fd_mask = present; then
printf "%s\n" "#define HAVE_SYS_SELECT_H 1" >>confdefs.h
tcl_ok=yes
fi
fi
if test $tcl_ok = no; then
printf "%s\n" "#define NO_FD_SET 1" >>confdefs.h
fi
#------------------------------------------------------------------------
# Options for the notifier. Checks for epoll(7) on Linux, and
# kqueue(2) on {DragonFly,Free,Net,Open}BSD
#------------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for advanced notifier support" >&5
printf %s "checking for advanced notifier support... " >&6; }
case x`uname -s` in
xLinux)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: epoll(7)" >&5
printf "%s\n" "epoll(7)" >&6; }
for ac_header in sys/epoll.h
do :
ac_fn_c_check_header_compile "$LINENO" "sys/epoll.h" "ac_cv_header_sys_epoll_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_epoll_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_EPOLL_H 1" >>confdefs.h
printf "%s\n" "#define NOTIFIER_EPOLL 1" >>confdefs.h
fi
done
for ac_header in sys/eventfd.h
do :
ac_fn_c_check_header_compile "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_eventfd_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_EVENTFD_H 1" >>confdefs.h
printf "%s\n" "#define HAVE_EVENTFD 1" >>confdefs.h
fi
done;;
xDragonFlyBSD|xFreeBSD|xNetBSD|xOpenBSD)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: kqueue(2)" >&5
printf "%s\n" "kqueue(2)" >&6; }
# Messy because we want to check if *all* the headers are present, and not
# just *any*
tcl_kqueue_headers=x
for ac_header in sys/types.h sys/event.h sys/time.h
do :
as_ac_Header=`printf "%s\n" "ac_cv_header_$ac_header" | $as_tr_sh`
ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default"
if eval test \"x\$"$as_ac_Header"\" = x"yes"
then :
cat >>confdefs.h <<_ACEOF
#define `printf "%s\n" "HAVE_$ac_header" | $as_tr_cpp` 1
_ACEOF
tcl_kqueue_headers=${tcl_kqueue_headers}y
fi
done
if test $tcl_kqueue_headers = xyyy
then :
printf "%s\n" "#define NOTIFIER_KQUEUE 1" >>confdefs.h
fi;;
xDarwin)
# Assume that we've got CoreFoundation present (checked elsewhere because
# of wider impact).
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: OSX" >&5
printf "%s\n" "OSX" >&6; };;
*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5
printf "%s\n" "none" >&6; };;
esac
#------------------------------------------------------------------------------
# Find out all about time handling differences.
#------------------------------------------------------------------------------
ac_fn_c_check_header_compile "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_time_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_TIME_H 1" >>confdefs.h
fi
# Obsolete code to be removed.
if test $ac_cv_header_sys_time_h = yes; then
printf "%s\n" "#define TIME_WITH_SYS_TIME 1" >>confdefs.h
fi
# End of obsolete code.
ac_fn_c_check_func "$LINENO" "gmtime_r" "ac_cv_func_gmtime_r"
if test "x$ac_cv_func_gmtime_r" = xyes
then :
printf "%s\n" "#define HAVE_GMTIME_R 1" >>confdefs.h
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
ac_fn_c_check_func "$LINENO" "mktime" "ac_cv_func_mktime"
if test "x$ac_cv_func_mktime" = xyes
then :
printf "%s\n" "#define HAVE_MKTIME 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 :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main (void)
{
struct tm tm; tm.tm_tzadj;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_member_tm_tzadj=yes
else $as_nop
tcl_cv_member_tm_tzadj=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_tzadj" >&5
printf "%s\n" "$tcl_cv_member_tm_tzadj" >&6; }
if test $tcl_cv_member_tm_tzadj = yes ; then
printf "%s\n" "#define HAVE_TM_TZADJ 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking tm_gmtoff in struct tm" >&5
printf %s "checking tm_gmtoff in struct tm... " >&6; }
if test ${tcl_cv_member_tm_gmtoff+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main (void)
{
struct tm tm; (void)tm.tm_gmtoff;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_member_tm_gmtoff=yes
else $as_nop
tcl_cv_member_tm_gmtoff=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_member_tm_gmtoff" >&5
printf "%s\n" "$tcl_cv_member_tm_gmtoff" >&6; }
if test $tcl_cv_member_tm_gmtoff = yes ; then
printf "%s\n" "#define HAVE_TM_GMTOFF 1" >>confdefs.h
fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking long timezone variable" >&5
printf %s "checking long timezone variable... " >&6; }
if test ${tcl_cv_timezone_long+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main (void)
{
extern long timezone;
timezone += 1;
exit (0);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_timezone_long=yes
else $as_nop
tcl_cv_timezone_long=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_long" >&5
printf "%s\n" "$tcl_cv_timezone_long" >&6; }
if test $tcl_cv_timezone_long = yes ; then
printf "%s\n" "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking time_t timezone variable" >&5
printf %s "checking time_t timezone variable... " >&6; }
if test ${tcl_cv_timezone_time+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main (void)
{
extern time_t timezone;
timezone += 1;
exit (0);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_timezone_time=yes
else $as_nop
tcl_cv_timezone_time=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_timezone_time" >&5
printf "%s\n" "$tcl_cv_timezone_time" >&6; }
if test $tcl_cv_timezone_time = yes ; then
printf "%s\n" "#define HAVE_TIMEZONE_VAR 1" >>confdefs.h
fi
fi
#--------------------------------------------------------------------
# Some systems (e.g., IRIX 4.0.5) lack some fields in struct stat. But
# we might be able to use fstatfs instead. Some systems (OpenBSD?) also
# lack blkcnt_t.
#--------------------------------------------------------------------
if test "$ac_cv_cygwin" != "yes"; then
ac_fn_c_check_member "$LINENO" "struct stat" "st_blocks" "ac_cv_member_struct_stat_st_blocks" "$ac_includes_default"
if test "x$ac_cv_member_struct_stat_st_blocks" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLOCKS 1" >>confdefs.h
fi
ac_fn_c_check_member "$LINENO" "struct stat" "st_blksize" "ac_cv_member_struct_stat_st_blksize" "$ac_includes_default"
if test "x$ac_cv_member_struct_stat_st_blksize" = xyes
then :
printf "%s\n" "#define HAVE_STRUCT_STAT_ST_BLKSIZE 1" >>confdefs.h
fi
fi
ac_fn_c_check_type "$LINENO" "blkcnt_t" "ac_cv_type_blkcnt_t" "$ac_includes_default"
if test "x$ac_cv_type_blkcnt_t" = xyes
then :
printf "%s\n" "#define HAVE_BLKCNT_T 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "fstatfs" "ac_cv_func_fstatfs"
if test "x$ac_cv_func_fstatfs" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_FSTATFS 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Some system have no memcmp or it does not work with 8 bit data, this
# checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working memcmp" >&5
printf %s "checking for working memcmp... " >&6; }
if test ${ac_cv_func_memcmp_working+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "$cross_compiling" = yes
then :
ac_cv_func_memcmp_working=no
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
main (void)
{
/* Some versions of memcmp are not 8-bit clean. */
char c0 = '\100', c1 = '\200', c2 = '\201';
if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0)
return 1;
|
| ︙ | ︙ | |||
8817 8818 8819 8820 8821 8822 8823 |
return 0;
}
;
return 0;
}
_ACEOF
| | > | | | | > | | | | > | | | | > | | | > | > > > < | > | | | | 9512 9513 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 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 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 |
return 0;
}
;
return 0;
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
ac_cv_func_memcmp_working=yes
else $as_nop
ac_cv_func_memcmp_working=no
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_memcmp_working" >&5
printf "%s\n" "$ac_cv_func_memcmp_working" >&6; }
test $ac_cv_func_memcmp_working = no && case " $LIBOBJS " in
*" memcmp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS memcmp.$ac_objext"
;;
esac
#--------------------------------------------------------------------
# Some system like SunOS 4 and other BSD like systems have no memmove
# (we assume they have bcopy instead). {The replacement define is in
# compat/string.h}
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "memmove" "ac_cv_func_memmove"
if test "x$ac_cv_func_memmove" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_MEMMOVE 1" >>confdefs.h
printf "%s\n" "#define NO_STRING_H 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even even if
# the original string is empty.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "strstr" "ac_cv_func_strstr"
if test "x$ac_cv_func_strstr" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 1; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking proper strstr implementation" >&5
printf %s "checking proper strstr implementation... " >&6; }
if test ${tcl_cv_strstr_unbroken+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "$cross_compiling" = yes
then :
tcl_cv_strstr_unbroken=unknown
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
exit(strstr("\0test", "test") ? 1 : 0);
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
tcl_cv_strstr_unbroken=ok
else $as_nop
tcl_cv_strstr_unbroken=broken
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strstr_unbroken" >&5
printf "%s\n" "$tcl_cv_strstr_unbroken" >&6; }
if test "$tcl_cv_strstr_unbroken" = "ok"; then
tcl_ok=1
else
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
|
| ︙ | ︙ | |||
8923 8924 8925 8926 8927 8928 8929 |
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "strtoul" "ac_cv_func_strtoul"
| | > | | | | > | | | > | > > > < | > | | | | 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 |
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "strtoul" "ac_cv_func_strtoul"
if test "x$ac_cv_func_strtoul" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 1; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking proper strtoul implementation" >&5
printf %s "checking proper strtoul implementation... " >&6; }
if test ${tcl_cv_strtoul_unbroken+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "$cross_compiling" = yes
then :
tcl_cv_strtoul_unbroken=unknown
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
int main() {
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
tcl_cv_strtoul_unbroken=ok
else $as_nop
tcl_cv_strtoul_unbroken=broken
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtoul_unbroken" >&5
printf "%s\n" "$tcl_cv_strtoul_unbroken" >&6; }
if test "$tcl_cv_strtoul_unbroken" = "ok"; then
tcl_ok=1
else
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
|
| ︙ | ︙ | |||
8981 8982 8983 8984 8985 8986 8987 | #-------------------------------------------------------------------- # 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" | | > | < | < > | > | > | > > > > > | > > > | > > > > > > > > > > > > > > > | > | < | < | | | > | | | > | | | | | | | | | > | | | | > | | | | | | < | < | < | < < < < < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < > | < | < | < | < < < < < | < < < < < < < < | < < < | | < < < < < < < < < < < < < < < < < < < < < | > | | | | | > | | | | > | | | | | | > | | | | > | | < < < | | > | | | | | > | | | | > | | < < < | | > | | | | | > | | 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 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 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 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 |
#--------------------------------------------------------------------
# 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"
if test "x$ac_cv_type_mode_t" = xyes
then :
else $as_nop
printf "%s\n" "#define mode_t int" >>confdefs.h
fi
ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default
"
if test "x$ac_cv_type_pid_t" = xyes
then :
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#if defined _WIN64 && !defined __CYGWIN__
LLP64
#endif
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_pid_type='int'
else $as_nop
ac_pid_type='__int64'
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
printf "%s\n" "#define pid_t $ac_pid_type" >>confdefs.h
fi
ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default"
if test "x$ac_cv_type_size_t" = xyes
then :
else $as_nop
printf "%s\n" "#define size_t unsigned int" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for uid_t in sys/types.h" >&5
printf %s "checking for uid_t in sys/types.h... " >&6; }
if test ${ac_cv_type_uid_t+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "uid_t" >/dev/null 2>&1
then :
ac_cv_type_uid_t=yes
else $as_nop
ac_cv_type_uid_t=no
fi
rm -rf conftest*
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_type_uid_t" >&5
printf "%s\n" "$ac_cv_type_uid_t" >&6; }
if test $ac_cv_type_uid_t = no; then
printf "%s\n" "#define uid_t int" >>confdefs.h
printf "%s\n" "#define gid_t int" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for socklen_t" >&5
printf %s "checking for socklen_t... " >&6; }
if test ${tcl_cv_type_socklen_t+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#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 :
tcl_cv_type_socklen_t=yes
else $as_nop
tcl_cv_type_socklen_t=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_type_socklen_t" >&5
printf "%s\n" "$tcl_cv_type_socklen_t" >&6; }
if test $tcl_cv_type_socklen_t = no; then
printf "%s\n" "#define socklen_t int" >>confdefs.h
fi
ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "
#include <stdint.h>
"
if test "x$ac_cv_type_intptr_t" = xyes
then :
printf "%s\n" "#define HAVE_INTPTR_T 1" >>confdefs.h
fi
ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "
#include <stdint.h>
"
if test "x$ac_cv_type_uintptr_t" = xyes
then :
printf "%s\n" "#define HAVE_UINTPTR_T 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
# then we have to supply a different version of dirent.h which
# is compatible with the substitute version of opendir that's
# provided. This version only works with V7-style directories.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "opendir" "ac_cv_func_opendir"
if test "x$ac_cv_func_opendir" = xyes
then :
else $as_nop
printf "%s\n" "#define USE_DIRENT2_H 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The check below checks whether <sys/wait.h> defines the type
# "union wait" correctly. It's needed because of weirdness in
# HP-UX where "union wait" is defined in both the BSD and SYS-V
# environments. Checking the usability of WIFEXITED seems to do
# the trick.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking union wait" >&5
printf %s "checking union wait... " >&6; }
if test ${tcl_cv_union_wait+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/types.h>
#include <sys/wait.h>
int
main (void)
{
union wait x;
WIFEXITED(x); /* Generates compiler error if WIFEXITED
* uses an int. */
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_union_wait=yes
else $as_nop
tcl_cv_union_wait=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_union_wait" >&5
printf "%s\n" "$tcl_cv_union_wait" >&6; }
if test $tcl_cv_union_wait = no; then
printf "%s\n" "#define NO_UNION_WAIT 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check whether there is an strncasecmp function on this system.
# This is a bit tricky because under SCO it's in -lsocket and
# under Sequent Dynix it's in -linet.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "strncasecmp" "ac_cv_func_strncasecmp"
if test "x$ac_cv_func_strncasecmp" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
if test "$tcl_ok" = 0; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -lsocket" >&5
printf %s "checking for strncasecmp in -lsocket... " >&6; }
if test ${ac_cv_lib_socket_strncasecmp+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-lsocket $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
main (void)
{
return strncasecmp ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_socket_strncasecmp=yes
else $as_nop
ac_cv_lib_socket_strncasecmp=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_strncasecmp" >&5
printf "%s\n" "$ac_cv_lib_socket_strncasecmp" >&6; }
if test "x$ac_cv_lib_socket_strncasecmp" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for strncasecmp in -linet" >&5
printf %s "checking for strncasecmp in -linet... " >&6; }
if test ${ac_cv_lib_inet_strncasecmp+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_check_lib_save_LIBS=$LIBS
LIBS="-linet $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
char strncasecmp ();
int
main (void)
{
return strncasecmp ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_lib_inet_strncasecmp=yes
else $as_nop
ac_cv_lib_inet_strncasecmp=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_strncasecmp" >&5
printf "%s\n" "$ac_cv_lib_inet_strncasecmp" >&6; }
if test "x$ac_cv_lib_inet_strncasecmp" = xyes
then :
tcl_ok=1
else $as_nop
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
case " $LIBOBJS " in
*" strncasecmp.$ac_objext "* ) ;;
|
| ︙ | ︙ | |||
9369 9370 9371 9372 9373 9374 9375 | # (set NO_GETTOD if this is the case). # 2. See if gettimeofday is declared in the <sys/time.h> header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" | | > | | | | | > | | | > | | | | | | | | > | | | | > | | | | | | | | | > | | | | > | | | | | | | | > | | | > | > | > | | | | | > | | | > | < | | | > | | | | > | | | | | | | > | | > | > | > | | < < > > > > | > | | | > | | | | > | | | | | < < | | < > | < < < < | | < > | < < < < < | | < > | < < < < | | < > | < < < < < | | < > | < < | | | | < < | | < > | < < < | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | < < | | < > | < < < < < | | < > | < < < | | | > | | | | | | | | | | | | | | | | > | | | | | | | > | | | | > | | | | | | | > | | | > | < | | | > | | > | > > > | | | | | | | | | | | | | > | | | | > | | | 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 10059 10060 10061 10062 10063 10064 10065 10066 10067 10068 10069 10070 10071 10072 10073 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 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 10158 10159 10160 10161 10162 10163 10164 10165 10166 10167 10168 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 10189 10190 10191 10192 10193 10194 10195 10196 10197 10198 10199 10200 10201 10202 10203 10204 10205 10206 10207 10208 10209 10210 10211 10212 10213 10214 10215 10216 10217 10218 10219 10220 10221 10222 10223 10224 10225 10226 10227 10228 10229 10230 10231 10232 10233 10234 10235 10236 10237 10238 10239 10240 10241 10242 10243 10244 10245 10246 10247 10248 10249 10250 10251 10252 10253 10254 10255 10256 10257 10258 10259 10260 10261 10262 10263 10264 10265 10266 10267 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 10285 10286 10287 10288 10289 10290 10291 10292 10293 10294 10295 10296 10297 10298 10299 10300 10301 10302 10303 10304 10305 10306 10307 10308 10309 10310 10311 10312 10313 10314 10315 10316 10317 10318 10319 10320 10321 10322 10323 10324 10325 10326 10327 10328 10329 10330 10331 10332 10333 10334 10335 10336 10337 10338 10339 10340 10341 10342 10343 10344 10345 10346 10347 10348 10349 10350 10351 10352 10353 10354 10355 10356 10357 10358 10359 10360 10361 10362 10363 10364 10365 10366 10367 10368 10369 10370 10371 10372 10373 10374 10375 10376 10377 10378 10379 10380 10381 10382 10383 10384 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 10425 10426 10427 10428 10429 10430 10431 10432 10433 10434 10435 10436 10437 10438 10439 10440 10441 10442 10443 10444 10445 10446 10447 10448 10449 10450 10451 10452 10453 10454 10455 10456 10457 10458 10459 10460 10461 10462 10463 10464 10465 10466 10467 10468 10469 10470 10471 10472 10473 10474 10475 10476 10477 10478 10479 10480 10481 10482 10483 10484 10485 10486 10487 10488 10489 10490 10491 10492 10493 10494 10495 10496 10497 10498 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 10592 10593 10594 10595 10596 10597 10598 10599 10600 10601 10602 10603 10604 10605 10606 10607 10608 10609 10610 10611 10612 10613 10614 10615 10616 10617 10618 10619 10620 10621 10622 10623 10624 10625 10626 10627 10628 10629 10630 10631 10632 10633 10634 10635 10636 10637 10638 10639 10640 10641 10642 10643 10644 10645 10646 10647 10648 10649 10650 10651 10652 10653 10654 10655 10656 10657 10658 10659 10660 10661 10662 10663 10664 10665 10666 10667 10668 10669 10670 10671 10672 10673 10674 10675 10676 10677 10678 10679 10680 10681 10682 10683 10684 10685 10686 10687 10688 10689 10690 10691 10692 10693 10694 10695 10696 10697 10698 10699 10700 10701 10702 10703 10704 10705 10706 10707 10708 10709 10710 10711 10712 10713 10714 10715 10716 10717 10718 10719 10720 10721 10722 10723 10724 10725 10726 10727 10728 10729 10730 10731 10732 10733 10734 10735 10736 10737 10738 10739 10740 10741 10742 10743 10744 10745 10746 10747 10748 10749 10750 10751 10752 10753 10754 10755 10756 10757 10758 10759 10760 10761 10762 10763 10764 10765 10766 10767 10768 10769 10770 10771 10772 10773 10774 10775 10776 10777 10778 10779 10780 10781 10782 10783 10784 10785 10786 10787 10788 10789 10790 10791 10792 10793 10794 10795 10796 10797 10798 10799 10800 10801 10802 10803 10804 10805 10806 10807 10808 10809 10810 10811 10812 10813 10814 10815 10816 10817 10818 10819 10820 10821 10822 10823 10824 10825 10826 10827 10828 10829 10830 10831 10832 10833 10834 10835 10836 |
# (set NO_GETTOD if this is the case).
# 2. See if gettimeofday is declared in the <sys/time.h> header file.
# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
# declare it.
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday"
if test "x$ac_cv_func_gettimeofday" = xyes
then :
else $as_nop
printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5
printf %s "checking for gettimeofday declaration... " >&6; }
if test ${tcl_cv_grep_gettimeofday+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/time.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "gettimeofday" >/dev/null 2>&1
then :
tcl_cv_grep_gettimeofday=present
else $as_nop
tcl_cv_grep_gettimeofday=missing
fi
rm -rf conftest*
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_grep_gettimeofday" >&5
printf "%s\n" "$tcl_cv_grep_gettimeofday" >&6; }
if test $tcl_cv_grep_gettimeofday = missing ; then
printf "%s\n" "#define GETTOD_NOT_DECLARED 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The following code checks to see whether it is possible to get
# signed chars on this platform. This is needed in order to
# properly generate sign-extended ints from character values.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether char is unsigned" >&5
printf %s "checking whether char is unsigned... " >&6; }
if test ${ac_cv_c_char_unsigned+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_includes_default
int
main (void)
{
static int test_array [1 - 2 * !(((char) -1) < 0)];
test_array [0] = 0;
return test_array [0];
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_c_char_unsigned=no
else $as_nop
ac_cv_c_char_unsigned=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_char_unsigned" >&5
printf "%s\n" "$ac_cv_c_char_unsigned" >&6; }
if test $ac_cv_c_char_unsigned = yes; then
printf "%s\n" "#define __CHAR_UNSIGNED__ 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking signed char declarations" >&5
printf %s "checking signed char declarations... " >&6; }
if test ${tcl_cv_char_signed+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
signed char *p;
p = 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_char_signed=yes
else $as_nop
tcl_cv_char_signed=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_char_signed" >&5
printf "%s\n" "$tcl_cv_char_signed" >&6; }
if test $tcl_cv_char_signed = yes; then
printf "%s\n" "#define HAVE_SIGNED_CHAR 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for a putenv() that copies the buffer" >&5
printf %s "checking for a putenv() that copies the buffer... " >&6; }
if test ${tcl_cv_putenv_copy+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "$cross_compiling" = yes
then :
tcl_cv_putenv_copy=no
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdlib.h>
#include <string.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
bar = getenv("havecopy");
if (!strcmp(bar, "no")) {
/* doesnt copy */
return 0;
} else {
/* does copy */
return 1;
}
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
tcl_cv_putenv_copy=no
else $as_nop
tcl_cv_putenv_copy=yes
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_putenv_copy" >&5
printf "%s\n" "$tcl_cv_putenv_copy" >&6; }
if test $tcl_cv_putenv_copy = yes; then
printf "%s\n" "#define HAVE_PUTENV_THAT_COPIES 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
# Check whether --enable-langinfo was given.
if test ${enable_langinfo+y}
then :
enableval=$enable_langinfo; langinfo_ok=$enableval
else $as_nop
langinfo_ok=yes
fi
HAVE_LANGINFO=0
if test "$langinfo_ok" = "yes"; then
ac_fn_c_check_header_compile "$LINENO" "langinfo.h" "ac_cv_header_langinfo_h" "$ac_includes_default"
if test "x$ac_cv_header_langinfo_h" = xyes
then :
langinfo_ok=yes
else $as_nop
langinfo_ok=no
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use nl_langinfo" >&5
printf %s "checking whether to use nl_langinfo... " >&6; }
if test "$langinfo_ok" = "yes"; then
if test ${tcl_cv_langinfo_h+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <langinfo.h>
int
main (void)
{
nl_langinfo(CODESET);
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_langinfo_h=yes
else $as_nop
tcl_cv_langinfo_h=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_langinfo_h" >&5
printf "%s\n" "$tcl_cv_langinfo_h" >&6; }
if test $tcl_cv_langinfo_h = yes; then
printf "%s\n" "#define HAVE_LANGINFO 1" >>confdefs.h
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $langinfo_ok" >&5
printf "%s\n" "$langinfo_ok" >&6; }
fi
#--------------------------------------------------------------------
# Check for support of cfmakeraw, chflags and mkstemps functions
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "cfmakeraw" "ac_cv_func_cfmakeraw"
if test "x$ac_cv_func_cfmakeraw" = xyes
then :
printf "%s\n" "#define HAVE_CFMAKERAW 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "chflags" "ac_cv_func_chflags"
if test "x$ac_cv_func_chflags" = xyes
then :
printf "%s\n" "#define HAVE_CHFLAGS 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "mkstemps" "ac_cv_func_mkstemps"
if test "x$ac_cv_func_mkstemps" = xyes
then :
printf "%s\n" "#define HAVE_MKSTEMPS 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check for support of isnan() function or macro
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking isnan" >&5
printf %s "checking isnan... " >&6; }
if test ${tcl_cv_isnan+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <math.h>
int
main (void)
{
isnan(0.0); /* Generates an error if isnan is missing */
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_isnan=yes
else $as_nop
tcl_cv_isnan=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_isnan" >&5
printf "%s\n" "$tcl_cv_isnan" >&6; }
if test $tcl_cv_isnan = no; then
printf "%s\n" "#define NO_ISNAN 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Darwin specific API checks and defines
#--------------------------------------------------------------------
if test "`uname -s`" = "Darwin" ; then
ac_fn_c_check_func "$LINENO" "getattrlist" "ac_cv_func_getattrlist"
if test "x$ac_cv_func_getattrlist" = xyes
then :
printf "%s\n" "#define HAVE_GETATTRLIST 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "copyfile.h" "ac_cv_header_copyfile_h" "$ac_includes_default"
if test "x$ac_cv_header_copyfile_h" = xyes
then :
printf "%s\n" "#define HAVE_COPYFILE_H 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "copyfile" "ac_cv_func_copyfile"
if test "x$ac_cv_func_copyfile" = xyes
then :
printf "%s\n" "#define HAVE_COPYFILE 1" >>confdefs.h
fi
if test $tcl_corefoundation = yes; then
ac_fn_c_check_header_compile "$LINENO" "libkern/OSAtomic.h" "ac_cv_header_libkern_OSAtomic_h" "$ac_includes_default"
if test "x$ac_cv_header_libkern_OSAtomic_h" = xyes
then :
printf "%s\n" "#define HAVE_LIBKERN_OSATOMIC_H 1" >>confdefs.h
fi
ac_fn_c_check_func "$LINENO" "OSSpinLockLock" "ac_cv_func_OSSpinLockLock"
if test "x$ac_cv_func_OSSpinLockLock" = xyes
then :
printf "%s\n" "#define HAVE_OSSPINLOCKLOCK 1" >>confdefs.h
fi
fi
printf "%s\n" "#define USE_VFORK 1" >>confdefs.h
printf "%s\n" "#define TCL_DEFAULT_ENCODING \"utf-8\"" >>confdefs.h
printf "%s\n" "#define TCL_LOAD_FROM_MEMORY 1" >>confdefs.h
printf "%s\n" "#define TCL_WIDE_CLICKS 1" >>confdefs.h
ac_fn_c_check_header_compile "$LINENO" "AvailabilityMacros.h" "ac_cv_header_AvailabilityMacros_h" "$ac_includes_default"
if test "x$ac_cv_header_AvailabilityMacros_h" = xyes
then :
printf "%s\n" "#define HAVE_AVAILABILITYMACROS_H 1" >>confdefs.h
fi
if test "$ac_cv_header_AvailabilityMacros_h" = yes; then
{ 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 $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#endif
#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#error MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#endif
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 $as_nop
tcl_cv_cc_weak_import=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
CFLAGS=$hold_cflags
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 $as_nop
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050
#error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050
#endif
#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050
#error MAC_OS_X_VERSION_MIN_REQUIRED < 1050
#endif
#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 $as_nop
tcl_cv_cc_darwin_c_source=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
CFLAGS=$hold_cflags
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
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=""
fi
#--------------------------------------------------------------------
# Check for support of fts functions (readdir replacement)
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fts" >&5
printf %s "checking for fts... " >&6; }
if test ${tcl_cv_api_fts+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <sys/param.h>
#include <sys/stat.h>
#include <fts.h>
int
main (void)
{
char*const p[2] = {"/", NULL};
FTS *f = fts_open(p, FTS_PHYSICAL|FTS_NOCHDIR|FTS_NOSTAT, NULL);
FTSENT *e = fts_read(f); fts_close(f);
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_api_fts=yes
else $as_nop
tcl_cv_api_fts=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_fts" >&5
printf "%s\n" "$tcl_cv_api_fts" >&6; }
if test $tcl_cv_api_fts = yes; then
printf "%s\n" "#define HAVE_FTS 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below check for systems where POSIX-style non-blocking
# I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems
# (mostly older ones), use the old BSD-style FIONBIO approach instead.
#--------------------------------------------------------------------
ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_ioctl_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "sys/filio.h" "ac_cv_header_sys_filio_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_filio_h" = xyes
then :
printf "%s\n" "#define HAVE_SYS_FILIO_H 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5
printf %s "checking system version... " >&6; }
if test ${tcl_cv_sys_version+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "${TEA_PLATFORM}" = "windows" ; then
tcl_cv_sys_version=windows
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
tcl_cv_sys_version=NetBSD-Debian
fi
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
printf "%s\n" "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
printf %s "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; }
case $system in
OSF*)
printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5
printf "%s\n" "FIONBIO" >&6; }
;;
*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5
printf "%s\n" "O_NONBLOCK" >&6; }
;;
esac
#------------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use dll unloading" >&5
printf %s "checking whether to use dll unloading... " >&6; }
# Check whether --enable-dll-unloading was given.
if test ${enable_dll_unloading+y}
then :
enableval=$enable_dll_unloading; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test $tcl_ok = yes; then
printf "%s\n" "#define TCL_UNLOAD_DLLS 1" >>confdefs.h
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
printf "%s\n" "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5
printf %s "checking for timezone data... " >&6; }
# Check whether --with-tzdata was given.
if test ${with_tzdata+y}
then :
withval=$with_tzdata; tcl_ok=$withval
else $as_nop
tcl_ok=auto
fi
#
# Any directories that get added here must also be added to the
# search path in ::tcl::clock::Initialize (library/clock.tcl).
#
case $tcl_ok in
no)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: supplied by OS vendor" >&5
printf "%s\n" "supplied by OS vendor" >&6; }
;;
yes)
# nothing to do here
;;
auto*)
if test ${tcl_cv_dir_zoneinfo+y}
then :
printf %s "(cached) " >&6
else $as_nop
for dir in /usr/share/zoneinfo \
/usr/share/lib/zoneinfo \
/usr/lib/zoneinfo
do
if test -f $dir/UTC -o -f $dir/GMT
then
tcl_cv_dir_zoneinfo="$dir"
break
fi
done
fi
if test -n "$tcl_cv_dir_zoneinfo"; then
tcl_ok=no
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $dir" >&5
printf "%s\n" "$dir" >&6; }
else
tcl_ok=yes
fi
;;
*)
as_fn_error $? "invalid argument: $tcl_ok" "$LINENO" 5
;;
esac
if test $tcl_ok = yes
then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: supplied by Tcl" >&5
printf "%s\n" "supplied by Tcl" >&6; }
INSTALL_TZDATA=install-tzdata
fi
#--------------------------------------------------------------------
# DTrace support
#--------------------------------------------------------------------
# Check whether --enable-dtrace was given.
if test ${enable_dtrace+y}
then :
enableval=$enable_dtrace; tcl_ok=$enableval
else $as_nop
tcl_ok=no
fi
if test $tcl_ok = yes; then
ac_fn_c_check_header_compile "$LINENO" "sys/sdt.h" "ac_cv_header_sys_sdt_h" "$ac_includes_default"
if test "x$ac_cv_header_sys_sdt_h" = xyes
then :
tcl_ok=yes
else $as_nop
tcl_ok=no
fi
fi
if test $tcl_ok = yes; then
# Extract the first word of "dtrace", so it can be a program name with args.
set dummy dtrace; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_path_DTRACE+y}
then :
printf %s "(cached) " >&6
else $as_nop
case $DTRACE in
[\\/]* | ?:[\\/]*)
ac_cv_path_DTRACE="$DTRACE" # Let the user override the test with a path.
;;
*)
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
as_dummy="$PATH:/usr/sbin"
for as_dir in $as_dummy
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_path_DTRACE="$as_dir$ac_word$ac_exec_ext"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
;;
esac
fi
DTRACE=$ac_cv_path_DTRACE
if test -n "$DTRACE"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $DTRACE" >&5
printf "%s\n" "$DTRACE" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
test -z "$ac_cv_path_DTRACE" && tcl_ok=no
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to enable DTrace support" >&5
printf %s "checking whether to enable DTrace support... " >&6; }
MAKEFILE_SHELL='/bin/sh'
if test $tcl_ok = yes; then
printf "%s\n" "#define USE_DTRACE 1" >>confdefs.h
DTRACE_SRC="\${DTRACE_SRC}"
DTRACE_HDR="\${DTRACE_HDR}"
if test "`uname -s`" != "Darwin" ; then
DTRACE_OBJ="\${DTRACE_OBJ}"
if test "`uname -s`" = "SunOS" -a "$SHARED_BUILD" = "0" ; then
# Need to create an intermediate object file to ensure tclDTrace.o
# gets included when linking against the static tcl library.
STLIB_LD='stlib_ld () { /usr/ccs/bin/ld -r -o $${1%.a}.o "$${@:2}" && '"${STLIB_LD}"' $${1} $${1%.a}.o ; } && stlib_ld'
MAKEFILE_SHELL='/bin/bash'
# Force use of Sun ar and ranlib, the GNU versions choke on
# tclDTrace.o and the combined object file above.
AR='/usr/ccs/bin/ar'
RANLIB='/usr/ccs/bin/ranlib'
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
printf "%s\n" "$tcl_ok" >&6; }
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
# Check whether --enable-zipfs was given.
if test ${enable_zipfs+y}
then :
enableval=$enable_zipfs; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; 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 $as_nop
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
|
| ︙ | ︙ | |||
10183 10184 10185 10186 10187 10188 10189 |
# 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'
| | | | > | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > | | | | > | | | | | | 10848 10849 10850 10851 10852 10853 10854 10855 10856 10857 10858 10859 10860 10861 10862 10863 10864 10865 10866 10867 10868 10869 10870 10871 10872 10873 10874 10875 10876 10877 10878 10879 10880 10881 10882 10883 10884 10885 10886 10887 10888 10889 10890 10891 10892 10893 10894 10895 10896 10897 10898 10899 10900 10901 10902 10903 10904 10905 10906 10907 10908 10909 10910 10911 10912 10913 10914 10915 10916 10917 10918 10919 10920 10921 10922 10923 10924 10925 10926 10927 10928 10929 10930 10931 10932 10933 10934 10935 10936 10937 10938 10939 10940 10941 10942 10943 10944 10945 10946 10947 10948 10949 10950 10951 10952 10953 10954 10955 10956 10957 10958 10959 10960 10961 10962 10963 10964 10965 10966 10967 10968 10969 10970 10971 10972 10973 10974 10975 10976 10977 10978 10979 10980 10981 10982 10983 10984 10985 10986 10987 10988 10989 10990 10991 10992 10993 10994 10995 10996 10997 10998 10999 11000 11001 11002 11003 11004 11005 11006 11007 11008 11009 11010 11011 11012 11013 11014 11015 11016 11017 11018 11019 11020 11021 11022 11023 |
# 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 $as_nop
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
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
#
# Find a native zip implementation
#
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
{ 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 $as_nop
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
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
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
printf %s "checking for building with zipfs... " >&6; }
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
printf "%s\n" "#define ZIPFS_BUILD 2" >>confdefs.h
INSTALL_LIBRARIES=install-libraries-zipfs-static
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
else
printf "%s\n" "#define ZIPFS_BUILD 1" >>confdefs.h
\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
#--------------------------------------------------------------------
# The check below checks whether the cpuid instruction is usable.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the cpuid instruction is usable" >&5
printf %s "checking whether the cpuid instruction is usable... " >&6; }
if test ${tcl_cv_cpuid+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
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 :
tcl_cv_cpuid=yes
else $as_nop
tcl_cv_cpuid=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cpuid" >&5
printf "%s\n" "$tcl_cv_cpuid" >&6; }
if test $tcl_cv_cpuid = yes; then
printf "%s\n" "#define HAVE_CPUID 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
10371 10372 10373 10374 10375 10376 10377 |
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
if test "`uname -s`" = "Darwin" ; then
| | | | > | | | | | | | | | | | | | | 11040 11041 11042 11043 11044 11045 11046 11047 11048 11049 11050 11051 11052 11053 11054 11055 11056 11057 11058 11059 11060 11061 11062 11063 11064 11065 11066 11067 11068 11069 11070 11071 11072 11073 11074 11075 11076 11077 11078 11079 11080 11081 11082 11083 11084 11085 11086 11087 11088 11089 11090 11091 11092 11093 11094 11095 11096 11097 11098 11099 11100 11101 11102 11103 11104 11105 |
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
if test "`uname -s`" = "Darwin" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to package libraries" >&5
printf %s "checking how to package libraries... " >&6; }
# Check whether --enable-framework was given.
if test ${enable_framework+y}
then :
enableval=$enable_framework; enable_framework=$enableval
else $as_nop
enable_framework=no
fi
if test $enable_framework = yes; then
if test $SHARED_BUILD = 0; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be built if --enable-shared is yes" >&5
printf "%s\n" "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;}
enable_framework=no
fi
if test $tcl_corefoundation = no; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Frameworks can only be used when CoreFoundation is available" >&5
printf "%s\n" "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;}
enable_framework=no
fi
fi
if test $enable_framework = yes; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: framework" >&5
printf "%s\n" "framework" >&6; }
FRAMEWORK_BUILD=1
else
if test $SHARED_BUILD = 1; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared library" >&5
printf "%s\n" "shared library" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static library" >&5
printf "%s\n" "static library" >&6; }
fi
FRAMEWORK_BUILD=0
fi
fi
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in"
TCL_YEAR="`date +%Y`"
fi
if test "$FRAMEWORK_BUILD" = "1" ; then
printf "%s\n" "#define TCL_FRAMEWORK 1" >>confdefs.h
# 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
|
| ︙ | ︙ | |||
10448 10449 10450 10451 10452 10453 10454 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 11118 11119 11120 11121 11122 11123 11124 11125 11126 11127 11128 11129 11130 11131 11132 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
10488 10489 10490 10491 10492 10493 10494 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
| | | | | 11158 11159 11160 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 11187 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
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} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ | |||
10615 10616 10617 10618 10619 10620 10621 |
# and sets the high bit in the cache file unless we assign to the vars.
(
for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
| | | | 11285 11286 11287 11288 11289 11290 11291 11292 11293 11294 11295 11296 11297 11298 11299 11300 |
# and sets the high bit in the cache file unless we assign to the vars.
(
for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
*) { eval $ac_var=; unset $ac_var;} ;;
esac ;;
esac
|
| ︙ | ︙ | |||
10646 10647 10648 10649 10650 10651 10652 |
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
| | | | | | | 11316 11317 11318 11319 11320 11321 11322 11323 11324 11325 11326 11327 11328 11329 11330 11331 11332 11333 11334 11335 11336 11337 11338 11339 11340 11341 11342 11343 11344 11345 11346 11347 11348 11349 11350 11351 11352 11353 |
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/
t end
s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
:end' >>confcache
if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
if test -w "$cache_file"; then
if test "x$cache_file" != "x/dev/null"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
printf "%s\n" "$as_me: updating cache $cache_file" >&6;}
if test ! -f "$cache_file" || test -h "$cache_file"; then
cat confcache >"$cache_file"
else
case $cache_file in #(
*/* | ?:*)
mv -f confcache "$cache_file"$$ &&
mv -f "$cache_file"$$ "$cache_file" ;; #(
*)
mv -f confcache "$cache_file" ;;
esac
fi
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
|
| ︙ | ︙ | |||
10724 10725 10726 10727 10728 10729 10730 |
CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""
: "${CONFIG_STATUS=./config.status}"
ac_write_fail=0
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
| | | | 11394 11395 11396 11397 11398 11399 11400 11401 11402 11403 11404 11405 11406 11407 11408 11409 |
CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""
: "${CONFIG_STATUS=./config.status}"
ac_write_fail=0
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;}
as_write_fail=0
cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1
#! $SHELL
# Generated by $as_me.
# Run this file to recreate the current configuration.
# Compiler output produced by configure, useful for debugging
# configure, is in config.log if it exists.
|
| ︙ | ︙ | |||
10748 10749 10750 10751 10752 10753 10754 | cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh | > | > | > > > > > > > > < < < < < < < < | | < | | < < < < < < | < < < < < < < | > > | < < > | | > > > > > > > > > | > > > > | < < < < < < < > | > > > | | < < < < < < < < < < < < < < < < < < < < | | > | 11418 11419 11420 11421 11422 11423 11424 11425 11426 11427 11428 11429 11430 11431 11432 11433 11434 11435 11436 11437 11438 11439 11440 11441 11442 11443 11444 11445 11446 11447 11448 11449 11450 11451 11452 11453 11454 11455 11456 11457 11458 11459 11460 11461 11462 11463 11464 11465 11466 11467 11468 11469 11470 11471 11472 11473 11474 11475 11476 11477 11478 11479 11480 11481 11482 11483 11484 11485 11486 11487 11488 11489 11490 11491 11492 11493 11494 11495 11496 11497 11498 11499 11500 11501 11502 11503 11504 11505 11506 11507 11508 11509 11510 11511 11512 11513 11514 11515 11516 11517 11518 11519 11520 11521 11522 11523 11524 11525 11526 11527 11528 11529 11530 11531 11532 11533 11534 11535 11536 11537 11538 11539 11540 11541 11542 11543 11544 11545 |
cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1
## -------------------- ##
## M4sh Initialization. ##
## -------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
as_nop=:
if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else $as_nop
case `(set -o) 2>/dev/null` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
# Reset variables that may have inherited troublesome values from
# the environment.
# IFS needs to be set, to space, tab, and newline, in precisely that order.
# (If _AS_PATH_WALK were called with IFS unset, it would have the
# side effect of setting IFS to empty, thus disabling word splitting.)
# Quoting is to prevent editors from complaining about space-tab.
as_nl='
'
export as_nl
IFS=" "" $as_nl"
PS1='$ '
PS2='> '
PS4='+ '
# Ensure predictable behavior from utilities with locale-dependent output.
LC_ALL=C
export LC_ALL
LANGUAGE=C
export LANGUAGE
# We cannot yet rely on "unset" to work, but we need these variables
# to be unset--not just set to an empty or harmless value--now, to
# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
# also avoids known problems related to "unset" and subshell syntax
# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
do eval test \${$as_var+y} \
&& ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
done
# Ensure that fds 0, 1, and 2 are open.
if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
# The user is always right.
if ${PATH_SEPARATOR+false} :; then
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
(PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
PATH_SEPARATOR=';'
}
fi
# Find who we are. Look in the path if we contain no directory separator.
as_myself=
case $0 in #((
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
test -r "$as_dir$0" && as_myself=$as_dir$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
exit 1
fi
# as_fn_error STATUS ERROR [LINENO LOG_FD]
# ----------------------------------------
# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
# script with STATUS, using 1 if that was 0.
as_fn_error ()
{
as_status=$1; test $as_status -eq 0 && as_status=1
if test "$4"; then
as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
printf "%s\n" "$as_me: error: $2" >&2
as_fn_exit $as_status
} # as_fn_error
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
|
| ︙ | ︙ | |||
10910 10911 10912 10913 10914 10915 10916 10917 10918 10919 10920 10921 10922 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
| > | > | | > | | 11560 11561 11562 11563 11564 11565 11566 11567 11568 11569 11570 11571 11572 11573 11574 11575 11576 11577 11578 11579 11580 11581 11582 11583 11584 11585 11586 11587 11588 11589 11590 11591 11592 11593 11594 11595 11596 11597 11598 11599 11600 11601 11602 11603 11604 11605 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
then :
eval 'as_fn_append ()
{
eval $1+=\$2
}'
else $as_nop
as_fn_append ()
{
eval $1=\$$1\$2
}
fi # as_fn_append
# as_fn_arith ARG...
# ------------------
# Perform arithmetic evaluation on the ARGs, and store the result in the
# global $as_val. Take advantage of shells that can avoid forks. The arguments
# must be portable across $(()) and expr.
if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
then :
eval 'as_fn_arith ()
{
as_val=$(( $* ))
}'
else $as_nop
as_fn_arith ()
{
as_val=`expr "$@" || test $? -eq 1`
}
fi # as_fn_arith
|
| ︙ | ︙ | |||
10969 10970 10971 10972 10973 10974 10975 | as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || | | | 11622 11623 11624 11625 11626 11627 11628 11629 11630 11631 11632 11633 11634 11635 11636 |
as_dirname=false
fi
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
|
| ︙ | ︙ | |||
10991 10992 10993 10994 10995 10996 10997 10998 10999 11000 11001 11002 11003 11004 11005 11006 11007 11008 11009 11010 11011 11012 11013 11014 11015 11016 |
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
| > > > > > > > > > > | 11644 11645 11646 11647 11648 11649 11650 11651 11652 11653 11654 11655 11656 11657 11658 11659 11660 11661 11662 11663 11664 11665 11666 11667 11668 11669 11670 11671 11672 11673 11674 11675 11676 11677 11678 11679 |
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# Determine whether it's possible to make 'echo' print without a newline.
# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
# for compatibility with existing Makefiles.
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
# For backward compatibility with old third-party macros, we provide
# the shell variables $as_echo and $as_echo_n. New code should use
# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
as_echo='printf %s\n'
as_echo_n='printf %s'
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
|
| ︙ | ︙ | |||
11045 11046 11047 11048 11049 11050 11051 |
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
| | | | 11708 11709 11710 11711 11712 11713 11714 11715 11716 11717 11718 11719 11720 11721 11722 11723 11724 11725 11726 11727 11728 11729 11730 11731 |
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
11117 11118 11119 11120 11121 11122 11123 | cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by tcl $as_me 8.7, which was | | | 11780 11781 11782 11783 11784 11785 11786 11787 11788 11789 11790 11791 11792 11793 11794 | cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by tcl $as_me 8.7, which was generated by GNU Autoconf 2.70. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
| ︙ | ︙ | |||
11170 11171 11172 11173 11174 11175 11176 11177 | Configuration commands: $config_commands Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 | > > | | | | 11833 11834 11835 11836 11837 11838 11839 11840 11841 11842 11843 11844 11845 11846 11847 11848 11849 11850 11851 11852 11853 11854 11855 11856 | Configuration commands: $config_commands Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ tcl config.status 8.7 configured by $0, generated by GNU Autoconf 2.70, with options \\"\$ac_cs_config\\" Copyright (C) 2020 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF |
| ︙ | ︙ | |||
11214 11215 11216 11217 11218 11219 11220 |
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
| | | | | | 11879 11880 11881 11882 11883 11884 11885 11886 11887 11888 11889 11890 11891 11892 11893 11894 11895 11896 11897 11898 11899 11900 11901 11902 11903 11904 11905 11906 11907 |
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
printf "%s\n" "$ac_cs_version"; exit ;;
--config | --confi | --conf | --con | --co | --c )
printf "%s\n" "$ac_cs_config"; exit ;;
--debug | --debu | --deb | --de | --d | -d )
debug=: ;;
--file | --fil | --fi | --f )
$ac_shift
case $ac_optarg in
*\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;
'') as_fn_error $? "missing file argument" ;;
esac
as_fn_append CONFIG_FILES " '$ac_optarg'"
ac_need_defaults=false;;
--he | --h | --help | --hel | -h )
printf "%s\n" "$ac_cs_usage"; exit ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil | --si | --s)
ac_cs_silent=: ;;
# This is an error.
-*) as_fn_error $? "unrecognized option: \`$1'
Try \`$0 --help' for more information." ;;
|
| ︙ | ︙ | |||
11256 11257 11258 11259 11260 11261 11262 | fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift | | | | 11921 11922 11923 11924 11925 11926 11927 11928 11929 11930 11931 11932 11933 11934 11935 11936 11937 11938 11939 11940 11941 11942 11943 11944 11945 11946 11947 11948 11949 |
fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
if \$ac_cs_recheck; then
set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
shift
\printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6
CONFIG_SHELL='$SHELL'
export CONFIG_SHELL
exec "\$@"
fi
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
exec 5>>config.log
{
echo
sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
printf "%s\n" "$ac_log"
} >&5
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
#
# INIT-COMMANDS
#
|
| ︙ | ︙ | |||
11306 11307 11308 11309 11310 11311 11312 | # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then | | | | 11971 11972 11973 11974 11975 11976 11977 11978 11979 11980 11981 11982 11983 11984 11985 11986 |
# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used. Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files
test ${CONFIG_COMMANDS+y} || CONFIG_COMMANDS=$config_commands
fi
# Have a temporary directory for convenience. Make it in the build tree
# simply because there is no reason against having it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# Hook for its removal unless debugging.
# Note that there is a small window in which the directory will not be cleaned:
|
| ︙ | ︙ | |||
11535 11536 11537 11538 11539 11540 11541 |
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
esac
| | | | | | | | 12200 12201 12202 12203 12204 12205 12206 12207 12208 12209 12210 12211 12212 12213 12214 12215 12216 12217 12218 12219 12220 12221 12222 12223 12224 12225 12226 12227 12228 12229 12230 12231 12232 12233 12234 12235 12236 12237 12238 12239 12240 12241 12242 12243 12244 12245 12246 12247 12248 12249 |
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
esac
case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
as_fn_append ac_file_inputs " '$ac_f'"
done
# Let's still pretend it is `configure' which instantiates (i.e., don't
# use $as_me), people would be surprised to read:
# /* config.h. Generated by config.status. */
configure_input='Generated from '`
printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
`' by configure.'
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
printf "%s\n" "$as_me: creating $ac_file" >&6;}
fi
# Neutralize special characters interpreted by sed in replacement strings.
case $configure_input in #(
*\&* | *\|* | *\\* )
ac_sed_conf_input=`printf "%s\n" "$configure_input" |
sed 's/[\\\\&|]/\\\\&/g'`;; #(
*) ac_sed_conf_input=$configure_input;;
esac
case $ac_tag in
*:-:* | *:-) cat >"$ac_tmp/stdin" \
|| as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;
esac
;;
esac
ac_dir=`$as_dirname -- "$ac_file" ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$ac_file" : 'X\(//\)[^/]' \| \
X"$ac_file" : 'X\(//\)$' \| \
X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$ac_file" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
11594 11595 11596 11597 11598 11599 11600 | s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) | | | | 12259 12260 12261 12262 12263 12264 12265 12266 12267 12268 12269 12270 12271 12272 12273 12274 12275 | s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix |
| ︙ | ︙ | |||
11649 11650 11651 11652 11653 11654 11655 | /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) | | | | 12314 12315 12316 12317 12318 12319 12320 12321 12322 12323 12324 12325 12326 12327 12328 12329 |
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p'
case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_datarootdir_hack='
s&@datadir@&$datadir&g
s&@docdir@&$docdir&g
s&@infodir@&$infodir&g
s&@localedir@&$localedir&g
|
| ︙ | ︙ | |||
11692 11693 11694 11695 11696 11697 11698 |
eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
>$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
"$ac_tmp/out"`; test -z "$ac_out"; } &&
| | | | | | 12357 12358 12359 12360 12361 12362 12363 12364 12365 12366 12367 12368 12369 12370 12371 12372 12373 12374 12375 12376 12377 12378 12379 12380 12381 12382 12383 12384 12385 12386 |
eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
>$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
"$ac_tmp/out"`; test -z "$ac_out"; } &&
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined" >&5
printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined" >&2;}
rm -f "$ac_tmp/stdin"
case $ac_file in
-) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;
*) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;
esac \
|| as_fn_error $? "could not create $ac_file" "$LINENO" 5
;;
:C) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5
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 &&
|
| ︙ | ︙ | |||
11754 11755 11756 11757 11758 11759 11760 | $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then | | | > | 12419 12420 12421 12422 12423 12424 12425 12426 12427 12428 12429 12430 12431 |
$SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
exec 5>>config.log
# Use ||, not &&, to avoid exiting from the if with $? = 1, which
# would make configure fail if this is the last instruction.
$ac_cs_success || as_fn_exit 1
fi
if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
|
Changes to unix/configure.ac.
1 2 3 4 5 6 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[8.7]) | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#! /bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
AC_INIT([tcl],[8.7])
AC_PREREQ([2.69])
dnl This is only used when included from macosx/configure.ac
m4_ifdef([SC_USE_CONFIG_HEADERS], [
AC_CONFIG_HEADERS([tclConfig.h:../unix/tclConfig.h.in])
AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"])
AH_TOP([
#ifndef _TCLCONFIG
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
# It makes compiling go faster. (This is only a performance feature.)
#------------------------------------------------------------------------
if test -z "$no_pipe" && test -n "$GCC"; then
AC_CACHE_CHECK([if the compiler understands -pipe],
tcl_cv_cc_pipe, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
| | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
# It makes compiling go faster. (This is only a performance feature.)
#------------------------------------------------------------------------
if test -z "$no_pipe" && test -n "$GCC"; then
AC_CACHE_CHECK([if the compiler understands -pipe],
tcl_cv_cc_pipe, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_pipe=yes],[tcl_cv_cc_pipe=no])
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 | AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) #------------------------------------------------------------------------ # Add stuff for libtommath libtommath_ok=yes AC_ARG_WITH(system-libtommath, | | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 |
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
AC_ARG_WITH(system-libtommath,
AS_HELP_STRING([--with-system-libtommath],
[use external libtommath (default: true if available, false otherwise)]),
[libtommath_ok=${withval}])
if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
AC_CHECK_HEADER([tommath.h],[
AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include <tommath.h>])],[
libtommath_ok=no])
AS_IF([test $libtommath_ok = yes], [
AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[
libtommath_ok=no])])
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | # systems like OSF/1 have a sys/select.h that's of no use, and # other systems like SCO UNIX have a sys/select.h that's # pernicious. If "fd_set" isn't defined anywhere then set a # special flag. #-------------------------------------------------------------------- AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [ | | | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
# systems like OSF/1 have a sys/select.h that's of no use, and
# other systems like SCO UNIX have a sys/select.h that's
# pernicious. If "fd_set" isn't defined anywhere then set a
# special flag.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>]], [[fd_set readMask, writeMask;]])],
[tcl_cv_type_fd_set=yes],[tcl_cv_type_fd_set=no])])
tcl_ok=$tcl_cv_type_fd_set
if test $tcl_ok = no; then
AC_CACHE_CHECK([for fd_mask in sys/select], tcl_cv_grep_fd_mask, [
AC_EGREP_HEADER(fd_mask, sys/select.h,
tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing)])
if test $tcl_cv_grep_fd_mask = present; then
AC_DEFINE(HAVE_SYS_SELECT_H, 1, [Should we include <sys/select.h>?])
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 | #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even even if # the original string is empty. #-------------------------------------------------------------------- SC_TCL_CHECK_BROKEN_FUNC(strstr, [ | < < | | | | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < | | | | | 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 |
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even even if
# the original string is empty.
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strstr, [
exit(strstr("\0test", "test") ? 1 : 0);
])
#--------------------------------------------------------------------
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
SC_TCL_CHECK_BROKEN_FUNC(strtoul, [
char *term, *string = "0";
exit(strtoul(string,&term,0) != 0 || term != string+1);
])
#--------------------------------------------------------------------
# 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>
]])
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
# then we have to supply a different version of dirent.h which
# is compatible with the substitute version of opendir that's
# provided. This version only works with V7-style directories.
#--------------------------------------------------------------------
AC_CHECK_FUNC(opendir, , [AC_DEFINE(USE_DIRENT2_H, 1, [May we include <dirent2.h>?])])
#--------------------------------------------------------------------
# The check below checks whether <sys/wait.h> defines the type
# "union wait" correctly. It's needed because of weirdness in
# HP-UX where "union wait" is defined in both the BSD and SYS-V
# environments. Checking the usability of WIFEXITED seems to do
# the trick.
#--------------------------------------------------------------------
AC_CACHE_CHECK([union wait], tcl_cv_union_wait, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
#include <sys/wait.h>]], [[
union wait x;
WIFEXITED(x); /* Generates compiler error if WIFEXITED
* uses an int. */
]])],[tcl_cv_union_wait=yes],[tcl_cv_union_wait=no])])
if test $tcl_cv_union_wait = no; then
AC_DEFINE(NO_UNION_WAIT, 1, [Do we have a usable 'union wait'?])
fi
#--------------------------------------------------------------------
# Check whether there is an strncasecmp function on this system.
# This is a bit tricky because under SCO it's in -lsocket and
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | # The following code checks to see whether it is possible to get # signed chars on this platform. This is needed in order to # properly generate sign-extended ints from character values. #-------------------------------------------------------------------- AC_C_CHAR_UNSIGNED AC_CACHE_CHECK([signed char declarations], tcl_cv_char_signed, [ | | | | > | | | | | 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 |
# The following code checks to see whether it is possible to get
# signed chars on this platform. This is needed in order to
# properly generate sign-extended ints from character values.
#--------------------------------------------------------------------
AC_C_CHAR_UNSIGNED
AC_CACHE_CHECK([signed char declarations], tcl_cv_char_signed, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[
signed char *p;
p = 0;
]])],[tcl_cv_char_signed=yes],[tcl_cv_char_signed=no])])
if test $tcl_cv_char_signed = yes; then
AC_DEFINE(HAVE_SIGNED_CHAR, 1, [Are characters signed?])
fi
#--------------------------------------------------------------------
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [
AC_RUN_IFELSE([AC_LANG_SOURCE([[
#include <stdlib.h>
#include <string.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
putenv(foo);
strcpy((char *)(strchr(foo, '=') + 1), "no");
bar = getenv("havecopy");
if (!strcmp(bar, "no")) {
/* doesnt copy */
return 0;
} else {
/* does copy */
return 1;
}
}
]])],
[tcl_cv_putenv_copy=no],
[tcl_cv_putenv_copy=yes],
[tcl_cv_putenv_copy=no])])
if test $tcl_cv_putenv_copy = yes; then
AC_DEFINE(HAVE_PUTENV_THAT_COPIES, 1,
[Does putenv() copy strings or incorporate them by reference?])
fi
#--------------------------------------------------------------------
# Check for support of nl_langinfo function
|
| ︙ | ︙ | |||
583 584 585 586 587 588 589 | AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) #-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- AC_CACHE_CHECK([isnan], tcl_cv_isnan, [ | | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
AC_CHECK_FUNCS(cfmakeraw chflags mkstemps)
#--------------------------------------------------------------------
# Check for support of isnan() function or macro
#--------------------------------------------------------------------
AC_CACHE_CHECK([isnan], tcl_cv_isnan, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <math.h>]], [[
isnan(0.0); /* Generates an error if isnan is missing */
]])],[tcl_cv_isnan=yes],[tcl_cv_isnan=no])])
if test $tcl_cv_isnan = no; then
AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?])
fi
#--------------------------------------------------------------------
# Darwin specific API checks and defines
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
[Can this platform load code from memory?])
AC_DEFINE(TCL_WIDE_CLICKS, 1,
[Does this platform have wide high-resolution clicks?])
AC_CHECK_HEADERS(AvailabilityMacros.h)
if test "$ac_cv_header_AvailabilityMacros_h" = yes; then
AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
| | | | | | | | | | | | 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 |
[Can this platform load code from memory?])
AC_DEFINE(TCL_WIDE_CLICKS, 1,
[Does this platform have wide high-resolution clicks?])
AC_CHECK_HEADERS(AvailabilityMacros.h)
if test "$ac_cv_header_AvailabilityMacros_h" = yes; then
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([[
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#endif
#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#error MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#endif
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([[
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050
#error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050
#endif
#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050
#error MAC_OS_X_VERSION_MIN_REQUIRED < 1050
#endif
#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
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=""
fi
#--------------------------------------------------------------------
# Check for support of fts functions (readdir replacement)
#--------------------------------------------------------------------
AC_CACHE_CHECK([for fts], tcl_cv_api_fts, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
#include <sys/param.h>
#include <sys/stat.h>
#include <fts.h>
]], [[
char*const p[2] = {"/", NULL};
FTS *f = fts_open(p, FTS_PHYSICAL|FTS_NOCHDIR|FTS_NOSTAT, NULL);
FTSENT *e = fts_read(f); fts_close(f);
]])],[tcl_cv_api_fts=yes],[tcl_cv_api_fts=no])])
if test $tcl_cv_api_fts = yes; then
AC_DEFINE(HAVE_FTS, 1, [Do we have fts functions?])
fi
#--------------------------------------------------------------------
# The statements below check for systems where POSIX-style non-blocking
# I/O (O_NONBLOCK) doesn't work or is unimplemented. On these systems
# (mostly older ones), use the old BSD-style FIONBIO approach instead.
#--------------------------------------------------------------------
SC_BLOCKING_STYLE
#------------------------------------------------------------------------
AC_MSG_CHECKING([whether to use dll unloading])
AC_ARG_ENABLE(dll-unloading,
AS_HELP_STRING([--enable-dll-unloading],
[enable the 'unload' command (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test $tcl_ok = yes; then
AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
AC_MSG_CHECKING([for timezone data])
AC_ARG_WITH(tzdata,
AS_HELP_STRING([--with-tzdata],
[install timezone data (default: autodetect)]),
[tcl_ok=$withval], [tcl_ok=auto])
#
# Any directories that get added here must also be added to the
# search path in ::tcl::clock::Initialize (library/clock.tcl).
#
case $tcl_ok in
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 | fi #-------------------------------------------------------------------- # DTrace support #-------------------------------------------------------------------- AC_ARG_ENABLE(dtrace, | | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 |
fi
#--------------------------------------------------------------------
# DTrace support
#--------------------------------------------------------------------
AC_ARG_ENABLE(dtrace,
AS_HELP_STRING([--enable-dtrace],
[build with DTrace support (default: off)]),
[tcl_ok=$enableval], [tcl_ok=no])
if test $tcl_ok = yes; then
AC_CHECK_HEADER(sys/sdt.h, [tcl_ok=yes], [tcl_ok=no])
fi
if test $tcl_ok = yes; then
AC_PATH_PROG(DTRACE, dtrace,, [$PATH:/usr/sbin])
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 | fi AC_MSG_RESULT([$tcl_ok]) #-------------------------------------------------------------------- # Zipfs support - Tip 430 #-------------------------------------------------------------------- AC_ARG_ENABLE(zipfs, | | | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
fi
AC_MSG_RESULT([$tcl_ok])
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
AC_ARG_ENABLE(zipfs,
AS_HELP_STRING([--enable-zipfs],
[build with Zipfs support (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
AX_CC_FOR_BUILD
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 | #-------------------------------------------------------------------- # The check below checks whether the cpuid instruction is usable. #-------------------------------------------------------------------- AC_CACHE_CHECK([whether the cpuid instruction is usable], tcl_cv_cpuid, [ | | | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 |
#--------------------------------------------------------------------
# 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
# building libtcl as a shared library instead of a static library.
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
SC_ENABLE_FRAMEWORK
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
| | | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
SC_ENABLE_FRAMEWORK
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in])
TCL_YEAR="`date +%Y`"
fi
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
| | | | | 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 |
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
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} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ |
Changes to unix/dltest/pkga.c.
1 2 3 4 5 6 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended for * testing the Tcl dynamic loading facilities. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
| > | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
(void)dummy;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
|
| ︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
static int
Pkga_QuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
| > > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
static int
Pkga_QuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
(void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "pkga", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd, NULL,
NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkgb.c.
1 2 3 | /* * pkgb.c -- * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * pkgb.c -- * * This file contains a simple Tcl package "Pkgb" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
Pkgb_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
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)) {
| > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
Pkgb_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
if (objc != 3) {
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)) {
|
| ︙ | ︙ | |||
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 |
static int
Pkgb_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
static int
Pkgb_DemoObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
Tcl_Obj *first;
if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
== TCL_OK) {
Tcl_SetObjResult(interp, first);
}
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
| > > > > > > > | 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 |
static int
Pkgb_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
static int
Pkgb_DemoObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
Tcl_Obj *first;
(void)dummy;
(void)objc;
(void)objv;
if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
== TCL_OK) {
Tcl_SetObjResult(interp, first);
}
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
|
| ︙ | ︙ |
Changes to unix/dltest/pkgc.c.
1 2 3 4 5 6 7 | /* * pkgc.c -- * * This file contains a simple Tcl package "pkgc" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * pkgc.c -- * * This file contains a simple Tcl package "pkgc" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
Pkgc_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
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)) {
| > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
Pkgc_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
if (objc != 3) {
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)) {
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
static int
Pkgc_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| > > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
static int
Pkgc_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "pkgc", "1.7.2");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkgd.c.
1 2 3 | /* * pkgd.c -- * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * pkgd.c -- * * This file contains a simple Tcl package "PKGD" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
Pkgd_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
if (objc != 3) {
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)) {
| > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
Pkgd_SubObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, second;
(void)dummy;
if (objc != 3) {
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)) {
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
static int
Pkgd_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| > > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
static int
Pkgd_UnsafeObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
(void)objc;
(void)objv;
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "PKGD", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd, NULL,
NULL);
return TCL_OK;
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
| | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
* made available. */
{
int code;
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvide(interp, "PKGD", "7.3");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkge.c.
1 2 3 4 5 6 7 | /* * pkge.c -- * * This file contains a simple Tcl package "pkge" that is intended for * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * pkge.c -- * * This file contains a simple Tcl package "pkge" that is intended for * testing the Tcl dynamic loading facilities. Its Init procedure returns * an error in order to test how this is handled. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tcl.h" |
| ︙ | ︙ |
Changes to unix/dltest/pkgooa.c.
1 2 3 4 5 6 | /* * pkgooa.c -- * * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * pkgooa.c -- * * This file contains a simple Tcl package "pkgooa" that is intended for * testing the Tcl dynamic loading facilities. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef STATIC_BUILD #include "tclOO.h" |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
static int
Pkgooa_StubsOKObjCmd(
ClientData dummy, /* Not used. */
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;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(
Tcl_CopyObjectInstance == tclOOStubsPtr->tcl_CopyObjectInstance));
return TCL_OK;
| > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
static int
Pkgooa_StubsOKObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
(void)dummy;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(
Tcl_CopyObjectInstance == tclOOStubsPtr->tcl_CopyObjectInstance));
return TCL_OK;
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
/* It doesn't really matter what implementation of
* Tcl_CopyObjectInstance is put in the "pseudo"
* stub table, since the test-case never actually
* calls this function. All that matters is that it's
* a function with a different memory address than
* the real Tcl_CopyObjectInstance function in Tcl. */
(Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *,
| | > > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
/* It doesn't really matter what implementation of
* Tcl_CopyObjectInstance is put in the "pseudo"
* stub table, since the test-case never actually
* calls this function. All that matters is that it's
* a function with a different memory address than
* the real Tcl_CopyObjectInstance function in Tcl. */
(Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *,
const char *t))(void *)Pkgooa_StubsOKObjCmd,
/* More entries could be here, but those are not used
* for this test-case. So, being NULL is OK. */
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
};
extern DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
* AIX), this code doesn't even compile without using
* stubs, but on UNIX ELF systems, the problem is
* less visible.
*/
tclOOStubsPtr = &stubsCopy;
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
* AIX), this code doesn't even compile without using
* stubs, but on UNIX ELF systems, the problem is
* less visible.
*/
tclOOStubsPtr = &stubsCopy;
code = Tcl_PkgProvide(interp, "pkgooa", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_CreateObjCommand(interp, "pkgooa_stubsok", Pkgooa_StubsOKObjCmd, NULL, NULL);
return TCL_OK;
}
|
Changes to unix/dltest/pkgua.c.
1 2 3 4 5 6 | /* * pkgua.c -- * * This file contains a simple Tcl package "pkgua" that is intended for * testing the Tcl dynamic unloading facilities. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * pkgua.c -- * * This file contains a simple Tcl package "pkgua" that is intended for * testing the Tcl dynamic unloading facilities. * * Copyright © 1995 Sun Microsystems, Inc. * Copyright © 2004 Georgios Petasis * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" |
| ︙ | ︙ | |||
121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
| > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
const char *str1, *str2;
int len1, len2;
(void)dummy;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
|
| ︙ | ︙ | |||
162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
static int
PkguaQuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
| > > | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
static int
PkguaQuoteObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
(void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
/*
* Initialise our Hash table, where we store the registered command tokens
* for each interpreter.
*/
PkguaInitTokensHashTable();
| | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
/*
* Initialise our Hash table, where we store the registered command tokens
* for each interpreter.
*/
PkguaInitTokensHashTable();
code = Tcl_PkgProvide(interp, "pkgua", "1.0");
if (code != TCL_OK) {
return code;
}
Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
cmdTokens = PkguaInterpToTokens(interp);
|
| ︙ | ︙ |
Changes to unix/install-sh.
1 2 3 | #!/bin/sh # install - install a program, script, or datafile | | | 1 2 3 4 5 6 7 8 9 10 11 | #!/bin/sh # install - install a program, script, or datafile scriptversion=2020-07-26.22; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent | | > | | < < | < < < < < < < < < < < < < < > > > > | | 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 |
# ings in this Software without prior written authorization from the X Consor-
# tium.
#
#
# FSF changes to this file are in the public domain.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# 'make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
tab=' '
nl='
'
IFS=" $tab$nl"
# Set DOITPROG to "echo" to test this script.
doit=${DOITPROG-}
doit_exec=${doit:-exec}
# Put in absolute file names if you don't have them in your path;
# or use environment vars.
chgrpprog=${CHGRPPROG-chgrp}
chmodprog=${CHMODPROG-chmod}
chownprog=${CHOWNPROG-chown}
cmpprog=${CMPPROG-cmp}
cpprog=${CPPROG-cp}
mkdirprog=${MKDIRPROG-mkdir}
mvprog=${MVPROG-mv}
rmprog=${RMPROG-rm}
stripprog=${STRIPPROG-strip}
posix_mkdir=
# Desired mode of installed file.
mode=0755
# Create dirs (including intermediate dirs) using mode 755.
# This is like GNU 'install' as of coreutils 8.32 (2020).
mkdir_umask=22
chgrpcmd=
chmodcmd=$chmodprog
chowncmd=
mvcmd=$mvprog
rmcmd="$rmprog -f"
stripcmd=
src=
dst=
dir_arg=
dst_arg=
copy_on_change=false
is_target_a_directory=possibly
usage="\
Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
or: $0 [OPTION]... SRCFILES... DIRECTORY
or: $0 [OPTION]... -t DIRECTORY SRCFILES...
or: $0 [OPTION]... -d DIRECTORIES...
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 | -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. | | | | < | | | | | | | > > | > > > > | | | | | | > > > > > > > > > > > > > > | > > > > > > > > > | | | | | | | 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 |
-c (ignored)
-C install only if different (preserve the last data modification time)
-d create directories instead of installing files.
-g GROUP $chgrpprog installed files to GROUP.
-m MODE $chmodprog installed files to MODE.
-o USER $chownprog installed files to USER.
-s $stripprog installed files.
-S OPTION $stripprog installed files using OPTION.
-t DIRECTORY install into DIRECTORY.
-T report an error if DSTFILE is a directory.
Environment variables override the default commands:
CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
RMPROG STRIPPROG
"
while test $# -ne 0; do
case $1 in
-c) ;;
-C) copy_on_change=true;;
-d) dir_arg=true;;
-g) chgrpcmd="$chgrpprog $2"
shift;;
--help) echo "$usage"; exit $?;;
-m) mode=$2
case $mode in
*' '* | *"$tab"* | *"$nl"* | *'*'* | *'?'* | *'['*)
echo "$0: invalid mode: $mode" >&2
exit 1;;
esac
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
-S) stripcmd="$stripprog $2"
shift;;
-t)
is_target_a_directory=always
dst_arg=$2
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
shift;;
-T) is_target_a_directory=never;;
--version) echo "$0 $scriptversion"; exit $?;;
--) shift
break;;
-*) echo "$0: invalid option: $1" >&2
exit 1;;
*) break;;
esac
shift
done
# We allow the use of options -d and -T together, by making -d
# take the precedence; this is for compatibility with GNU install.
if test -n "$dir_arg"; then
if test -n "$dst_arg"; then
echo "$0: target directory not allowed when installing a directory." >&2
exit 1
fi
fi
if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
# When -d is used, all remaining arguments are directories to create.
# When -t is used, the destination is already specified.
# Otherwise, the last argument is the destination. Remove it from $@.
for arg
do
if test -n "$dst_arg"; then
# $@ is not empty: it contains at least $arg.
set fnord "$@" "$dst_arg"
shift # fnord
fi
shift # arg
dst_arg=$arg
# Protect names problematic for 'test' and other utilities.
case $dst_arg in
-* | [=\(\)!]) dst_arg=./$dst_arg;;
esac
done
fi
if test $# -eq 0; then
if test -z "$dir_arg"; then
echo "$0: no input file specified." >&2
exit 1
fi
# It's OK to call 'install-sh -d' without argument.
# This can happen when creating conditional directories.
exit 0
fi
if test -z "$dir_arg"; then
if test $# -gt 1 || test "$is_target_a_directory" = always; then
if test ! -d "$dst_arg"; then
echo "$0: $dst_arg: Is not a directory." >&2
exit 1
fi
fi
fi
if test -z "$dir_arg"; then
do_exit='(exit $ret); exit $ret'
trap "ret=129; $do_exit" 1
trap "ret=130; $do_exit" 2
trap "ret=141; $do_exit" 13
trap "ret=143; $do_exit" 15
# Set umask so as not to create temps with too-generous modes.
# However, 'strip' requires both read and write access to temps.
case $mode in
# Optimize common cases.
*644) cp_umask=133;;
*755) cp_umask=22;;
*[0-7])
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw='% 200'
fi
cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
*)
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw=,u+rw
fi
cp_umask=$mode$u_plus_rw;;
esac
fi
for src
do
# Protect names problematic for 'test' and other utilities.
case $src in
-* | [=\(\)!]) src=./$src;;
esac
if test -n "$dir_arg"; then
dst=$src
dstdir=$dst
test -d "$dstdir"
dstdir_status=$?
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
exit 1
fi
if test -z "$dst_arg"; then
echo "$0: no destination specified." >&2
exit 1
fi
| < < < < < | < | | | | > > > > < | < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > < < < < < < < < < < < < < < < < | | | | | | | | | < < < < < > | | > > > > > > > > > | > | | | | | | | > | | | | | | | | | | | | | | | | | | | < | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | | | < < | | < | | | | | | | | | | | | | | | | | | | | 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 |
exit 1
fi
if test -z "$dst_arg"; then
echo "$0: no destination specified." >&2
exit 1
fi
dst=$dst_arg
# If destination is a directory, append the input filename.
if test -d "$dst"; then
if test "$is_target_a_directory" = never; then
echo "$0: $dst_arg: Is a directory" >&2
exit 1
fi
dstdir=$dst
dstbase=`basename "$src"`
case $dst in
*/) dst=$dst$dstbase;;
*) dst=$dst/$dstbase;;
esac
dstdir_status=0
else
dstdir=`dirname "$dst"`
test -d "$dstdir"
dstdir_status=$?
fi
fi
case $dstdir in
*/) dstdirslash=$dstdir;;
*) dstdirslash=$dstdir/;;
esac
obsolete_mkdir_used=false
if test $dstdir_status != 0; then
case $posix_mkdir in
'')
# With -d, create the new directory with the user-specified mode.
# Otherwise, rely on $mkdir_umask.
if test -n "$dir_arg"; then
mkdir_mode=-m$mode
else
mkdir_mode=
fi
posix_mkdir=false
# The $RANDOM variable is not portable (e.g., dash). Use it
# here however when possible just to lower collision chance.
tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
trap '
ret=$?
rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir" 2>/dev/null
exit $ret
' 0
# Because "mkdir -p" follows existing symlinks and we likely work
# directly in world-writeable /tmp, make sure that the '$tmpdir'
# directory is successfully created first before we actually test
# 'mkdir -p'.
if (umask $mkdir_umask &&
$mkdirprog $mkdir_mode "$tmpdir" &&
exec $mkdirprog $mkdir_mode -p -- "$tmpdir/a/b") >/dev/null 2>&1
then
if test -z "$dir_arg" || {
# Check for POSIX incompatibilities with -m.
# HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
# other-writable bit of parent directory when it shouldn't.
# FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
test_tmpdir="$tmpdir/a"
ls_ld_tmpdir=`ls -ld "$test_tmpdir"`
case $ls_ld_tmpdir in
d????-?r-*) different_mode=700;;
d????-?--*) different_mode=755;;
*) false;;
esac &&
$mkdirprog -m$different_mode -p -- "$test_tmpdir" && {
ls_ld_tmpdir_1=`ls -ld "$test_tmpdir"`
test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
}
}
then posix_mkdir=:
fi
rmdir "$tmpdir/a/b" "$tmpdir/a" "$tmpdir"
else
# Remove any dirs left behind by ancient mkdir implementations.
rmdir ./$mkdir_mode ./-p ./-- "$tmpdir" 2>/dev/null
fi
trap '' 0;;
esac
if
$posix_mkdir && (
umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
)
then :
else
# mkdir does not conform to POSIX,
# or it failed possibly due to a race condition. Create the
# directory the slow way, step by step, checking for races as we go.
case $dstdir in
/*) prefix='/';;
[-=\(\)!]*) prefix='./';;
*) prefix='';;
esac
oIFS=$IFS
IFS=/
set -f
set fnord $dstdir
shift
set +f
IFS=$oIFS
prefixes=
for d
do
test X"$d" = X && continue
prefix=$prefix$d
if test -d "$prefix"; then
prefixes=
else
if $posix_mkdir; then
(umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
# Don't fail if two instances are running concurrently.
test -d "$prefix" || exit 1
else
case $prefix in
*\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
*) qprefix=$prefix;;
esac
prefixes="$prefixes '$qprefix'"
fi
fi
prefix=$prefix/
done
if test -n "$prefixes"; then
# Don't fail if two instances are running concurrently.
(umask $mkdir_umask &&
eval "\$doit_exec \$mkdirprog $prefixes") ||
test -d "$dstdir" || exit 1
obsolete_mkdir_used=true
fi
fi
fi
if test -n "$dir_arg"; then
{ test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
{ test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
else
# Make a couple of temp file names in the proper directory.
dsttmp=${dstdirslash}_inst.$$_
rmtmp=${dstdirslash}_rm.$$_
# Trap to clean up those temp files at exit.
trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
# Copy the file name to the temp name.
(umask $cp_umask &&
{ test -z "$stripcmd" || {
# Create $dsttmp read-write so that cp doesn't create it read-only,
# which would cause strip to fail.
if test -z "$doit"; then
: >"$dsttmp" # No need to fork-exec 'touch'.
else
$doit touch "$dsttmp"
fi
}
} &&
$doit_exec $cpprog "$src" "$dsttmp") &&
# and set any options; do chmod last to preserve setuid bits.
#
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $cpprog $src $dsttmp" command.
#
{ test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
{ test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
{ test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
# If -C, don't bother to copy if it wouldn't change the file.
if $copy_on_change &&
old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` &&
new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` &&
set -f &&
set X $old && old=:$2:$4:$5:$6 &&
set X $new && new=:$2:$4:$5:$6 &&
set +f &&
test "$old" = "$new" &&
$cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
then
rm -f "$dsttmp"
else
# Rename the file to the real destination.
$doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
# The rename failed, perhaps because mv can't rename something else
# to itself, or perhaps because mv is so ancient that it does not
# support -f.
{
# Now remove or move aside any old file at destination location.
# We try this two ways since rm can't unlink itself on some
# systems and the destination file might be busy for other
# reasons. In this case, the final cleanup might fail but the new
# file should still install successfully.
{
test ! -f "$dst" ||
$doit $rmcmd -f "$dst" 2>/dev/null ||
{ $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
{ $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
} ||
{ echo "$0: cannot unlink or rename $dst" >&2
(exit 1); exit 1
}
} &&
# Now rename the file to the real destination.
$doit $mvcmd "$dsttmp" "$dst"
}
fi || exit 1
trap '' 0
fi
done
# Local variables:
# eval: (add-hook 'before-save-hook 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:
|
Changes to unix/installManPage.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
if test -d "$Dir" ; then : ; else
echo "target directory must exist"
exit 1
fi
test -z "$SymOrLoc" && SymOrLoc="$Dir/"
########################################################################
### Extract Target Names from Manual Page
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 | Name=`basename $ManPage .$Section` SrcDir=`dirname $ManPage` ######################################################################## ### Process Page to Create Target Pages ### | | | | | | | | 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 |
Name=`basename $ManPage .$Section`
SrcDir=`dirname $ManPage`
########################################################################
### Process Page to Create Target Pages
###
Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock FindPhoto FontId MeasureChar"
for n in $Specials; do
if [ "$Name" = "$n" ] ; then
Names="$n $Names"
fi
done
First=""
for Target in $Names; do
Target=$Target.$Section$Suffix
rm -f "$Dir/$Target" "$Dir/$Target.*"
if test -z "$First" ; then
First=$Target
sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \
$ManPage > "$Dir/$First"
chmod 644 "$Dir/$First"
$Gzip "$Dir/$First"
else
ln $SymOrLoc"$First$Gz" "$Dir/$Target$Gz"
fi
done
########################################################################
exit 0
|
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
# we reset no_tcl in case something fails here
no_tcl=true
AC_ARG_WITH(tcl,
| | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
# we reset no_tcl in case something fails here
no_tcl=true
AC_ARG_WITH(tcl,
AS_HELP_STRING([--with-tcl],
[directory containing tcl configuration (tclConfig.sh)]),
[with_tclconfig="${withval}"])
AC_MSG_CHECKING([for Tcl configuration])
AC_CACHE_VAL(ac_cv_c_tclconfig,[
# First check to see if --with-tcl was specified.
if test x"${with_tclconfig}" != x ; then
case "${with_tclconfig}" in
*/tclConfig.sh )
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
# we reset no_tk in case something fails here
no_tk=true
AC_ARG_WITH(tk,
| | | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
# we reset no_tk in case something fails here
no_tk=true
AC_ARG_WITH(tk,
AS_HELP_STRING([--with-tk],
[directory containing tk configuration (tkConfig.sh)]),
[with_tkconfig="${withval}"])
AC_MSG_CHECKING([for Tk configuration])
AC_CACHE_VAL(ac_cv_c_tkconfig,[
# First check to see if --with-tkconfig was specified.
if test x"${with_tkconfig}" != x ; then
case "${with_tkconfig}" in
*/tkConfig.sh )
|
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
| | < < < < < < < < | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
AS_HELP_STRING([--enable-shared],
[build and link with shared libraries (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
# FRAMEWORK_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_FRAMEWORK], [
if test "`uname -s`" = "Darwin" ; then
AC_MSG_CHECKING([how to package libraries])
AC_ARG_ENABLE(framework,
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
# FRAMEWORK_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_FRAMEWORK], [
if test "`uname -s`" = "Darwin" ; then
AC_MSG_CHECKING([how to package libraries])
AC_ARG_ENABLE(framework,
AS_HELP_STRING([--enable-framework],
[package shared libraries in MacOSX frameworks (default: off)]),
[enable_framework=$enableval], [enable_framework=no])
if test $enable_framework = yes; then
if test $SHARED_BUILD = 0; then
AC_MSG_WARN([Frameworks can only be built if --enable-shared is yes])
enable_framework=no
fi
|
| ︙ | ︙ | |||
605 606 607 608 609 610 611 |
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols,
| | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols,
AS_HELP_STRING([--enable-symbols],
[build with debugging symbols (default: off)]),
[tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
#
# Defines the following vars:
# HAVE_LANGINFO Triggers use of nl_langinfo if defined.
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_LANGINFO], [
AC_ARG_ENABLE(langinfo,
| | | | 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 |
#
# Defines the following vars:
# HAVE_LANGINFO Triggers use of nl_langinfo if defined.
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_LANGINFO], [
AC_ARG_ENABLE(langinfo,
AS_HELP_STRING([--enable-langinfo],
[use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]),
[langinfo_ok=$enableval], [langinfo_ok=yes])
HAVE_LANGINFO=0
if test "$langinfo_ok" = "yes"; then
AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no])
fi
AC_MSG_CHECKING([whether to use nl_langinfo])
if test "$langinfo_ok" = "yes"; then
AC_CACHE_VAL(tcl_cv_langinfo_h, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]], [[nl_langinfo(CODESET);]])],
[tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])])
AC_MSG_RESULT([$tcl_cv_langinfo_h])
if test $tcl_cv_langinfo_h = yes; then
AC_DEFINE(HAVE_LANGINFO, 1, [Do we have nl_langinfo()?])
fi
else
AC_MSG_RESULT([$langinfo_ok])
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
# according to the user's selection.
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_MANPAGES], [
AC_MSG_CHECKING([whether to use symlinks for manpages])
AC_ARG_ENABLE(man-symlinks,
| | | | | | | | | 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 |
# according to the user's selection.
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_MANPAGES], [
AC_MSG_CHECKING([whether to use symlinks for manpages])
AC_ARG_ENABLE(man-symlinks,
AS_HELP_STRING([--enable-man-symlinks],
[use symlinks for the manpages (default: off)]),
[test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"],
[enableval="no"])
AC_MSG_RESULT([$enableval])
AC_MSG_CHECKING([whether to compress the manpages])
AC_ARG_ENABLE(man-compression,
AS_HELP_STRING([--enable-man-compression=PROG],
[compress the manpages with PROG (default: off)]),
[case $enableval in
yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
esac],
[enableval="no"])
AC_MSG_RESULT([$enableval])
if test "$enableval" != "no"; then
AC_MSG_CHECKING([for compressed file suffix])
touch TeST
$enableval TeST
Z=`ls TeST* | sed 's/^....//'`
rm -f TeST*
MAN_FLAGS="$MAN_FLAGS --extension $Z"
AC_MSG_RESULT([$Z])
fi
AC_MSG_CHECKING([whether to add a package name suffix for the manpages])
AC_ARG_ENABLE(man-suffix,
AS_HELP_STRING([--enable-man-suffix=STRING],
[use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]),
[case $enableval in
yes) enableval="AC_PACKAGE_NAME" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
esac],
[enableval="no"])
AC_MSG_RESULT([$enableval])
AC_SUBST(MAN_FLAGS)
])
#--------------------------------------------------------------------
# SC_CONFIG_SYSTEM
|
| ︙ | ︙ | |||
888 889 890 891 892 893 894 |
AC_DEFUN([SC_CONFIG_CFLAGS], [
# Step 0.a: Enable 64 bit support?
AC_MSG_CHECKING([if 64bit support is requested])
AC_ARG_ENABLE(64bit,
| | | | | | | | 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 |
AC_DEFUN([SC_CONFIG_CFLAGS], [
# Step 0.a: Enable 64 bit support?
AC_MSG_CHECKING([if 64bit support is requested])
AC_ARG_ENABLE(64bit,
AS_HELP_STRING([--enable-64bit],
[enable 64bit support (default: off)]),
[do64bit=$enableval], [do64bit=no])
AC_MSG_RESULT([$do64bit])
# Step 0.b: Enable Solaris 64 bit VIS support?
AC_MSG_CHECKING([if 64bit Sparc VIS support is requested])
AC_ARG_ENABLE(64bit-vis,
AS_HELP_STRING([--enable-64bit-vis],
[enable 64bit Sparc VIS support (default: off)]),
[do64bitVIS=$enableval], [do64bitVIS=no])
AC_MSG_RESULT([$do64bitVIS])
# Force 64bit on with VIS
AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes])
# Step 0.c: Check if visibility support is available. Do this here so
# that platform specific alternatives can be used below if this fails.
AC_CACHE_CHECK([if compiler supports visibility "hidden"],
tcl_cv_cc_visibility_hidden, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[
extern __attribute__((__visibility__("hidden"))) void f(void);
void f(void) {}]], [[f();]])],[tcl_cv_cc_visibility_hidden=yes],
[tcl_cv_cc_visibility_hidden=no])
CFLAGS=$hold_cflags])
AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [
AC_DEFINE(MODULE_SCOPE,
[extern __attribute__((__visibility__("hidden")))],
[Compiler support for module scope symbols])
AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols])
])
# Step 0.d: Disable -rpath support?
AC_MSG_CHECKING([if rpath support is requested])
AC_ARG_ENABLE(rpath,
AS_HELP_STRING([--disable-rpath],
[disable rpath support (default: on)]),
[doRpath=$enableval], [doRpath=yes])
AC_MSG_RESULT([$doRpath])
# Step 1: set the variable "system" to hold the name and version number
# for the system.
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
| > > > > > > > > | | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
AS_IF([test "$GCC" = yes], [
CFLAGS_OPTIMIZE=-O2
CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement"
;;
esac
], [
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
])
AC_CHECK_TOOL(AR, ar)
STLIB_LD='${AR} cr'
LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
|
| ︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | | | | | | 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 |
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*|MINGW32_*|MSYS_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a'
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a"
AC_CACHE_CHECK(for Cygwin version of gcc,
ac_cv_cygwin,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#ifdef __CYGWIN__
#error cygwin
#endif
]], [[]])],
[ac_cv_cygwin=no],
[ac_cv_cygwin=yes])
)
if test "$ac_cv_cygwin" = "no"; then
AC_MSG_ERROR([${CC} is not a cygwin compiler.])
fi
do64bit_ok=yes
if test "x${SHARED_BUILD}" = "x1"; then
echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args"
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
| | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
AC_MSG_WARN([64bit mode not supported with GCC on $system])
;;
esac
], [
|
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 | SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
], [
case $system in
IRIX-6.3)
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 | SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | | | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
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)
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"
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, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_m64=yes],[tcl_cv_cc_m64=no])
CFLAGS=$hold_cflags])
AS_IF([test $tcl_cv_cc_m64 = yes], [
CFLAGS="$CFLAGS -m64"
do64bit_ok=yes
])
])
|
| ︙ | ︙ | |||
1303 1304 1305 1306 1307 1308 1309 |
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
| | | | | 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 |
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -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=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
LIBS=`echo $LIBS | sed s/-lpthread//`
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
| | < | | | 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 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]"
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='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 | AS_IF([test $do64bit = yes], [ case `arch` in ppc) AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag], tcl_cv_cc_arch_ppc64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" | | | | | | | | | | | | | | | | | | 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 |
AS_IF([test $do64bit = yes], [
case `arch` in
ppc)
AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag],
tcl_cv_cc_arch_ppc64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_arch_ppc64=yes],
[tcl_cv_cc_arch_ppc64=no])
CFLAGS=$hold_cflags])
AS_IF([test $tcl_cv_cc_arch_ppc64 = yes], [
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
do64bit_ok=yes
]);;
i386)
AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag],
tcl_cv_cc_arch_x86_64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch x86_64"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_cc_arch_x86_64=yes],
[tcl_cv_cc_arch_x86_64=no])
CFLAGS=$hold_cflags])
AS_IF([test $tcl_cv_cc_arch_x86_64 = yes], [
CFLAGS="$CFLAGS -arch x86_64"
do64bit_ok=yes
]);;
*)
AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);;
esac
], [
# Check for combined 32-bit and 64-bit fat build
AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \
&& echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [
fat_32_64=yes])
])
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])],[tcl_cv_ld_single_module=yes],[tcl_cv_ld_single_module=no])
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_single_module = yes], [
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
])
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
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[int i;]])],[tcl_cv_ld_search_paths_first=yes],
[tcl_cv_ld_search_paths_first=no])
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_search_paths_first = yes], [
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [__private_extern__],
[Compiler support for module scope symbols])
tcl_cv_cc_visibility_hidden=yes
])
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?])
PLAT_OBJS='${MAC_OSX_OBJS}'
PLAT_SRCS='${MAC_OSX_SRCS}'
AC_MSG_CHECKING([whether to use CoreFoundation])
AC_ARG_ENABLE(corefoundation,
AS_HELP_STRING([--enable-corefoundation],
[use CoreFoundation API on MacOSX (default: on)]),
[tcl_corefoundation=$enableval], [tcl_corefoundation=yes])
AC_MSG_RESULT([$tcl_corefoundation])
AS_IF([test $tcl_corefoundation = yes], [
AC_CACHE_CHECK([for CoreFoundation.framework],
tcl_cv_lib_corefoundation, [
hold_libs=$LIBS
AS_IF([test "$fat_32_64" = yes], [
for v in CFLAGS CPPFLAGS LDFLAGS; do
# On Tiger there is no 64-bit CF, so remove 64-bit
# archs from CFLAGS et al. while testing for
# presence of CF. 64-bit CF is disabled in
# tclUnixPort.h if necessary.
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"'
done])
LIBS="$LIBS -framework CoreFoundation"
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],[
AC_CACHE_CHECK([for 64-bit CoreFoundation],
tcl_cv_lib_corefoundation_64, [
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"'
done
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <CoreFoundation/CoreFoundation.h>]],
[[CFBundleRef b = CFBundleGetMainBundle();]])],
[tcl_cv_lib_corefoundation_64=yes],
[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"
|
| ︙ | ︙ | |||
1528 1529 1530 1531 1532 1533 1534 | ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ | | < | 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 |
], [
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
])
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}'])
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
AS_IF([test "$GCC" = yes], [
LIBS="$LIBS -lpthread -lmach -lexc"
], [
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
])
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
CC_SEARCH_FLAGS=""
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | DL_OBJS="tclLoadDl.o" 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" | | | 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 | DL_OBJS="tclLoadDl.o" 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="" ;; |
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 |
dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's
dnl # preprocessing tests use only CPPFLAGS.
AC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""])
# Step 4: disable dynamic loading if requested via a command-line switch.
AC_ARG_ENABLE(load,
| | | 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 |
dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's
dnl # preprocessing tests use only CPPFLAGS.
AC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""])
# Step 4: disable dynamic loading if requested via a command-line switch.
AC_ARG_ENABLE(load,
AS_HELP_STRING([--enable-load],
[allow dynamic loading and "load" command (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
AS_IF([test "$tcl_ok" = no], [DL_OBJS=""])
AS_IF([test "x$DL_OBJS" != x], [BUILD_DLTEST="\$(DLTEST_TARGETS)"], [
AC_MSG_WARN([Can't figure out how to do dynamic loading or shared libraries on this system.])
SHLIB_CFLAGS=""
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
| | > > > | | | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 |
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*|MINGW32_*|MSYS_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [extern],
[No Compiler support for module scope symbols])
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 | # 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, tcl_cv_cast_to_union, | | < | | | | 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 |
# 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,
tcl_cv_cast_to_union,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[
union foo { int i; double d; };
union foo f = (union foo) (int) 0;
]])],
[tcl_cv_cast_to_union=yes],
[tcl_cv_cast_to_union=no])
)
if test "$tcl_cv_cast_to_union" = "yes"; then
AC_DEFINE(HAVE_CAST_TO_UNION, 1,
[Defined when compiler supports casting to union type.])
fi
AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],)
|
| ︙ | ︙ | |||
1914 1915 1916 1917 1918 1919 1920 |
# HAVE_SYS_PARAM_H
# HAVE_STRING_H ?
#
#--------------------------------------------------------------------
AC_DEFUN([SC_MISSING_POSIX_HEADERS], [
AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [
| | | | | 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 |
# HAVE_SYS_PARAM_H
# HAVE_STRING_H ?
#
#--------------------------------------------------------------------
AC_DEFUN([SC_MISSING_POSIX_HEADERS], [
AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [
AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
#include <dirent.h>]], [[
#ifndef _POSIX_SOURCE
# ifdef __Lynx__
/*
* Generate compilation error to make the test fail: Lynx headers
* are only valid if really in the POSIX environment.
*/
missing_procedure();
# endif
#endif
DIR *d;
struct dirent *entryPtr;
char *p;
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
]])],[tcl_cv_dirent_h=yes],[tcl_cv_dirent_h=no])])
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
fi
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
|
| ︙ | ︙ | |||
1960 1961 1962 1963 1964 1965 1966 |
AC_DEFINE(NO_STRING_H, 1, [Do we have <string.h>?])
fi
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).
| | | 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 |
AC_DEFINE(NO_STRING_H, 1, [Do we have <string.h>?])
fi
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])
])
#--------------------------------------------------------------------
# SC_PATH_X
#
# Locate the X11 header files and the X11 library archive. Try
# the ac_path_x macro first, but if it doesn't find the X stuff
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
#--------------------------------------------------------------------
AC_DEFUN([SC_PATH_X], [
AC_PATH_X
not_really_there=""
if test "$no_x" = ""; then
if test "$x_includes" = ""; then
| | | | 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 |
#--------------------------------------------------------------------
AC_DEFUN([SC_PATH_X], [
AC_PATH_X
not_really_there=""
if test "$no_x" = ""; then
if test "$x_includes" = ""; then
AC_PREPROC_IFELSE([AC_LANG_SOURCE([[#include <X11/Xlib.h>]])],[],[not_really_there="yes"])
else
if test ! -r $x_includes/X11/Xlib.h; then
not_really_there="yes"
fi
fi
fi
if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
AC_MSG_CHECKING([for X11 header files])
found_xincludes="no"
AC_PREPROC_IFELSE([AC_LANG_SOURCE([[#include <X11/Xlib.h>]])],[found_xincludes="yes"],[found_xincludes="no"])
if test "$found_xincludes" = "no"; then
dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
for i in $dirs ; do
if test -r $i/X11/Xlib.h; then
AC_MSG_RESULT([$i])
XINCLUDES=" -I$i"
found_xincludes="yes"
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
# HAVE_TM_TZADJ
# HAVE_TIMEZONE_VAR
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
| > > > > > > > > > > > > > | | | | | | | | | | | | | | 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 |
# HAVE_TM_TZADJ
# HAVE_TIMEZONE_VAR
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
m4_warn([obsolete],
[Update your code to rely only on HAVE_SYS_TIME_H,
then remove this warning and the obsolete code below it.
All current systems provide time.h; it need not be checked for.
Not all systems provide sys/time.h, but those that do, all allow
you to include it and time.h simultaneously.])dnl
AC_CHECK_HEADERS_ONCE([sys/time.h])
# Obsolete code to be removed.
if test $ac_cv_header_sys_time_h = yes; then
AC_DEFINE([TIME_WITH_SYS_TIME],[1],[Define to 1 if you can safely include both <sys/time.h>
and <time.h>. This macro is obsolete.])
fi
# End of obsolete code.
AC_CHECK_FUNCS(gmtime_r localtime_r mktime)
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; 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?])
fi
AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <time.h>]], [[struct tm tm; (void)tm.tm_gmtoff;]])],
[tcl_cv_member_tm_gmtoff=yes],[tcl_cv_member_tm_gmtoff=no])])
if test $tcl_cv_member_tm_gmtoff = yes ; then
AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?])
fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <time.h>]],
[[extern long timezone;
timezone += 1;
exit (0);]])],
[tcl_cv_timezone_long=yes],[tcl_cv_timezone_long=no])])
if test $tcl_cv_timezone_long = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <time.h>]],
[[extern time_t timezone;
timezone += 1;
exit (0);]])],
[tcl_cv_timezone_time=yes],[tcl_cv_timezone_time=no])])
if test $tcl_cv_timezone_time = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?])
fi
fi
])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 |
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([for 64-bit integer type])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
# See if the compiler knows natively about __int64
| | | | | | | | | | | | | | | | | | | | 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 |
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([for 64-bit integer type])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
# See if the compiler knows natively about __int64
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[__int64 value = (__int64) 0;]])],
[tcl_type_64bit=__int64],[tcl_type_64bit="long long"])
# 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(${tcl_type_64bit})==sizeof(long)): ;
}]])],[tcl_cv_type_64bit=${tcl_type_64bit}],[])])
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_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit},
[What type should be used to define wide integers?])
AC_MSG_RESULT([${tcl_cv_type_64bit}])
# Now check for auxiliary declarations
AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
#include <dirent.h>]], [[struct dirent64 p;]])],
[tcl_cv_struct_dirent64=yes],[tcl_cv_struct_dirent64=no])])
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_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/stat.h>]], [[struct stat64 p;
]])],
[tcl_cv_struct_stat64=yes],[tcl_cv_struct_stat64=no])])
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in <sys/stat.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])
|
| ︙ | ︙ | |||
2431 2432 2433 2434 2435 2436 2437 |
# Will define the following vars:
# TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding,
| | | | | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
# Will define the following vars:
# TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding,
AS_HELP_STRING([--with-encoding],
[encoding for configuration values (default: utf-8)]),
[with_tcencoding=${withval}])
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}",
[What encoding should be used for embedded configuration info?])
else
AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8",
[What encoding should be used for embedded configuration info?])
fi
])
#--------------------------------------------------------------------
# SC_TCL_CHECK_BROKEN_FUNC
#
|
| ︙ | ︙ | |||
2464 2465 2466 2467 2468 2469 2470 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[
AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0)
if test ["$tcl_ok"] = 1; then
AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken],
| > > > | | | 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 |
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[
AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0)
if test ["$tcl_ok"] = 1; then
AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken],
AC_RUN_IFELSE([AC_LANG_SOURCE([[[
#include <stdlib.h>
#include <string.h>
int main() {]$2[}]]])],[tcl_cv_$1_unbroken=ok],
[tcl_cv_$1_unbroken=broken],[tcl_cv_$1_unbroken=unknown]))
if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then
tcl_ok=1
else
tcl_ok=0
fi
fi
if test ["$tcl_ok"] = 0; then
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 |
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_DECL], [AC_CHECK_DECLS(gethostbyaddr_r, [
tcl_cv_api_gethostbyaddr_r=yes],[tcl_cv_api_gethostbyaddr_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_TYPE], [AC_CHECK_FUNC(gethostbyaddr_r, [
AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [
| | | | | | | | 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 |
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_DECL], [AC_CHECK_DECLS(gethostbyaddr_r, [
tcl_cv_api_gethostbyaddr_r=yes],[tcl_cv_api_gethostbyaddr_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_TYPE], [AC_CHECK_FUNC(gethostbyaddr_r, [
AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <netdb.h>
]], [[
char *addr;
int length;
int type;
struct hostent *result;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&h_errnop);
]])],[tcl_cv_api_gethostbyaddr_r_7=yes],[tcl_cv_api_gethostbyaddr_r_7=no])])
tcl_ok=$tcl_cv_api_gethostbyaddr_r_7
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYADDR_R_7, 1,
[Define to 1 if gethostbyaddr_r takes 7 args.])
else
AC_CACHE_CHECK([for gethostbyaddr_r with 8 args], tcl_cv_api_gethostbyaddr_r_8, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <netdb.h>
]], [[
char *addr;
int length;
int type;
struct hostent *result, *resultp;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&resultp, &h_errnop);
]])],[tcl_cv_api_gethostbyaddr_r_8=yes],[tcl_cv_api_gethostbyaddr_r_8=no])])
tcl_ok=$tcl_cv_api_gethostbyaddr_r_8
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYADDR_R_8, 1,
[Define to 1 if gethostbyaddr_r takes 8 args.])
fi
fi
if test "$tcl_ok" = yes; then
|
| ︙ | ︙ | |||
2591 2592 2593 2594 2595 2596 2597 |
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_DECL], [AC_CHECK_DECLS(gethostbyname_r, [
tcl_cv_api_gethostbyname_r=yes],[tcl_cv_api_gethostbyname_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_TYPE], [AC_CHECK_FUNC(gethostbyname_r, [
AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [
| | | | | | | | | | | 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 |
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_DECL], [AC_CHECK_DECLS(gethostbyname_r, [
tcl_cv_api_gethostbyname_r=yes],[tcl_cv_api_gethostbyname_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_TYPE], [AC_CHECK_FUNC(gethostbyname_r, [
AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <netdb.h>
]], [[
char *name;
struct hostent *he, *res;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &res, &h_errnop);
]])],[tcl_cv_api_gethostbyname_r_6=yes],[tcl_cv_api_gethostbyname_r_6=no])])
tcl_ok=$tcl_cv_api_gethostbyname_r_6
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_6, 1,
[Define to 1 if gethostbyname_r takes 6 args.])
else
AC_CACHE_CHECK([for gethostbyname_r with 5 args], tcl_cv_api_gethostbyname_r_5, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <netdb.h>
]], [[
char *name;
struct hostent *he;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &h_errnop);
]])],[tcl_cv_api_gethostbyname_r_5=yes],[tcl_cv_api_gethostbyname_r_5=no])])
tcl_ok=$tcl_cv_api_gethostbyname_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_5, 1,
[Define to 1 if gethostbyname_r takes 5 args.])
else
AC_CACHE_CHECK([for gethostbyname_r with 3 args], tcl_cv_api_gethostbyname_r_3, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <netdb.h>
]], [[
char *name;
struct hostent *he;
struct hostent_data data;
(void) gethostbyname_r(name, he, &data);
]])],[tcl_cv_api_gethostbyname_r_3=yes],[tcl_cv_api_gethostbyname_r_3=no])])
tcl_ok=$tcl_cv_api_gethostbyname_r_3
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_3, 1,
[Define to 1 if gethostbyname_r takes 3 args.])
fi
fi
fi
|
| ︙ | ︙ | |||
2667 2668 2669 2670 2671 2672 2673 |
# HAVE_GETPWUID_R_4
# HAVE_GETPWUID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWUID_R], [AC_CHECK_FUNC(getpwuid_r, [
AC_CACHE_CHECK([for getpwuid_r with 5 args], tcl_cv_api_getpwuid_r_5, [
| | | | | | | | 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 |
# HAVE_GETPWUID_R_4
# HAVE_GETPWUID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWUID_R], [AC_CHECK_FUNC(getpwuid_r, [
AC_CACHE_CHECK([for getpwuid_r with 5 args], tcl_cv_api_getpwuid_r_5, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <pwd.h>
]], [[
uid_t uid;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwuid_r(uid, &pw, buf, buflen, &pwp);
]])],[tcl_cv_api_getpwuid_r_5=yes],[tcl_cv_api_getpwuid_r_5=no])])
tcl_ok=$tcl_cv_api_getpwuid_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWUID_R_5, 1,
[Define to 1 if getpwuid_r takes 5 args.])
else
AC_CACHE_CHECK([for getpwuid_r with 4 args], tcl_cv_api_getpwuid_r_4, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <pwd.h>
]], [[
uid_t uid;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(uid, &pw, buf, buflen);
]])],[tcl_cv_api_getpwuid_r_4=yes],[tcl_cv_api_getpwuid_r_4=no])])
tcl_ok=$tcl_cv_api_getpwuid_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWUID_R_4, 1,
[Define to 1 if getpwuid_r takes 4 args.])
fi
fi
if test "$tcl_ok" = yes; then
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 |
# HAVE_GETPWNAM_R_4
# HAVE_GETPWNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWNAM_R], [AC_CHECK_FUNC(getpwnam_r, [
AC_CACHE_CHECK([for getpwnam_r with 5 args], tcl_cv_api_getpwnam_r_5, [
| | | | | | | | 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 |
# HAVE_GETPWNAM_R_4
# HAVE_GETPWNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWNAM_R], [AC_CHECK_FUNC(getpwnam_r, [
AC_CACHE_CHECK([for getpwnam_r with 5 args], tcl_cv_api_getpwnam_r_5, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <pwd.h>
]], [[
char *name;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwnam_r(name, &pw, buf, buflen, &pwp);
]])],[tcl_cv_api_getpwnam_r_5=yes],[tcl_cv_api_getpwnam_r_5=no])])
tcl_ok=$tcl_cv_api_getpwnam_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWNAM_R_5, 1,
[Define to 1 if getpwnam_r takes 5 args.])
else
AC_CACHE_CHECK([for getpwnam_r with 4 args], tcl_cv_api_getpwnam_r_4, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <pwd.h>
]], [[
char *name;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(name, &pw, buf, buflen);
]])],[tcl_cv_api_getpwnam_r_4=yes],[tcl_cv_api_getpwnam_r_4=no])])
tcl_ok=$tcl_cv_api_getpwnam_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWNAM_R_4, 1,
[Define to 1 if getpwnam_r takes 4 args.])
fi
fi
if test "$tcl_ok" = yes; then
|
| ︙ | ︙ | |||
2787 2788 2789 2790 2791 2792 2793 |
# HAVE_GETGRGID_R_4
# HAVE_GETGRGID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRGID_R], [AC_CHECK_FUNC(getgrgid_r, [
AC_CACHE_CHECK([for getgrgid_r with 5 args], tcl_cv_api_getgrgid_r_5, [
| | | | | | | | 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 |
# HAVE_GETGRGID_R_4
# HAVE_GETGRGID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRGID_R], [AC_CHECK_FUNC(getgrgid_r, [
AC_CACHE_CHECK([for getgrgid_r with 5 args], tcl_cv_api_getgrgid_r_5, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <grp.h>
]], [[
gid_t gid;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrgid_r(gid, &gr, buf, buflen, &grp);
]])],[tcl_cv_api_getgrgid_r_5=yes],[tcl_cv_api_getgrgid_r_5=no])])
tcl_ok=$tcl_cv_api_getgrgid_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRGID_R_5, 1,
[Define to 1 if getgrgid_r takes 5 args.])
else
AC_CACHE_CHECK([for getgrgid_r with 4 args], tcl_cv_api_getgrgid_r_4, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <grp.h>
]], [[
gid_t gid;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrgid_r(gid, &gr, buf, buflen);
]])],[tcl_cv_api_getgrgid_r_4=yes],[tcl_cv_api_getgrgid_r_4=no])])
tcl_ok=$tcl_cv_api_getgrgid_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRGID_R_4, 1,
[Define to 1 if getgrgid_r takes 4 args.])
fi
fi
if test "$tcl_ok" = yes; then
|
| ︙ | ︙ | |||
2847 2848 2849 2850 2851 2852 2853 |
# HAVE_GETGRNAM_R_4
# HAVE_GETGRNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRNAM_R], [AC_CHECK_FUNC(getgrnam_r, [
AC_CACHE_CHECK([for getgrnam_r with 5 args], tcl_cv_api_getgrnam_r_5, [
| | | | | | | | 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 |
# HAVE_GETGRNAM_R_4
# HAVE_GETGRNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRNAM_R], [AC_CHECK_FUNC(getgrnam_r, [
AC_CACHE_CHECK([for getgrnam_r with 5 args], tcl_cv_api_getgrnam_r_5, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <grp.h>
]], [[
char *name;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrnam_r(name, &gr, buf, buflen, &grp);
]])],[tcl_cv_api_getgrnam_r_5=yes],[tcl_cv_api_getgrnam_r_5=no])])
tcl_ok=$tcl_cv_api_getgrnam_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRNAM_R_5, 1,
[Define to 1 if getgrnam_r takes 5 args.])
else
AC_CACHE_CHECK([for getgrnam_r with 4 args], tcl_cv_api_getgrnam_r_4, [
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#include <sys/types.h>
#include <grp.h>
]], [[
char *name;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrnam_r(name, &gr, buf, buflen);
]])],[tcl_cv_api_getgrnam_r_4=yes],[tcl_cv_api_getgrnam_r_4=no])])
tcl_ok=$tcl_cv_api_getgrnam_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRNAM_R_4, 1,
[Define to 1 if getgrnam_r takes 4 args.])
fi
fi
if test "$tcl_ok" = yes; then
|
| ︙ | ︙ |
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 |
# 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: 8.7a4
Release: 2
License: BSD
Group: Development/Languages
Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
URL: http://www.tcl.tk/
Buildroot: /var/tmp/%{name}%{version}
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
1 2 3 4 5 6 7 8 9 10 11 12 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
| > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
/* ../unix/tclConfig.h.in. Generated from configure.ac by autoheader. */
#ifndef _TCLCONFIG
#define _TCLCONFIG
/* Define if building universal (internal helper macro) */
#undef AC_APPLE_UNIVERSAL_BUILD
/* Is gettimeofday() actually declared in <sys/time.h>? */
#undef GETTOD_NOT_DECLARED
/* Define to 1 if you have the <AvailabilityMacros.h> header file. */
#undef HAVE_AVAILABILITYMACROS_H
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R /* Define to 1 if you have the `lseek64' function. */ #undef HAVE_LSEEK64 | < < < | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | /* Define to 1 if you have the `localtime_r' function. */ #undef HAVE_LOCALTIME_R /* Define to 1 if you have the `lseek64' function. */ #undef HAVE_LSEEK64 /* Define to 1 if you have the `mkstemp' function. */ #undef HAVE_MKSTEMP /* Define to 1 if you have the `mkstemps' function. */ #undef HAVE_MKSTEMPS /* Define to 1 if you have the `mktime' function. */ |
| ︙ | ︙ | |||
197 198 199 200 201 202 203 204 205 206 207 208 209 210 | #undef HAVE_SIGNED_CHAR /* Do we have <stdbool.h>? */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the <strings.h> header file. */ #undef HAVE_STRINGS_H | > > > | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 | #undef HAVE_SIGNED_CHAR /* Do we have <stdbool.h>? */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the <stdio.h> header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the <strings.h> header file. */ #undef HAVE_STRINGS_H |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | /* Define to 1 if the system has the type `struct sockaddr_storage'. */ #undef HAVE_STRUCT_SOCKADDR_STORAGE /* Is 'struct stat64' in <sys/stat.h>? */ #undef HAVE_STRUCT_STAT64 /* Define to 1 if `st_blksize' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE /* Define to 1 if `st_blocks' is a member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the <sys/epoll.h> header file. */ #undef HAVE_SYS_EPOLL_H /* Define to 1 if you have the <sys/eventfd.h> header file. */ #undef HAVE_SYS_EVENTFD_H |
| ︙ | ︙ | |||
302 303 304 305 306 307 308 309 310 311 312 313 314 315 | #undef HAVE_ZLIB /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Is no debugging enabled? */ #undef NDEBUG /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 | > > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | #undef HAVE_ZLIB /* 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. */ #undef MP_PREC /* Is no debugging enabled? */ #undef NDEBUG /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 |
| ︙ | ︙ | |||
377 378 379 380 381 382 383 384 385 386 387 388 389 390 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD | > > > | > > | 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 | #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD /* Define to 1 if all of the C90 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #undef STDC_HEADERS /* What encoding should be used for embedded configuration info? */ #undef TCL_CFGVAL_ENCODING /* Is this a 64-bit build? */ #undef TCL_CFG_DO64BIT |
| ︙ | ︙ | |||
429 430 431 432 433 434 435 | /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE | > > > | > | | > > > > > > | > > | 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 | /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Tcl with external libtommath */ #undef TCL_WITH_EXTERNAL_TOMMATH /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This macro is obsolete. */ #undef TIME_WITH_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* May we include <dirent2.h>? */ #undef USE_DIRENT2_H /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ #undef USE_FIONBIO /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Are we building with zipfs enabled? */ #undef ZIPFS_BUILD /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE |
| ︙ | ︙ | |||
484 485 486 487 488 489 490 | /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE_EXTENDED | | > | | | 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 | /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE_EXTENDED /* Define to 1 if type `char' is unsigned and your compiler does not predefine this macro. */ #ifndef __CHAR_UNSIGNED__ # undef __CHAR_UNSIGNED__ #endif /* Define to `int' if <sys/types.h> doesn't define. */ #undef gid_t /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus #undef inline #endif /* Signed integer type wide enough to hold a pointer. */ #undef intptr_t /* Define to `int' if <sys/types.h> does not define. */ #undef mode_t /* Define as a signed integer type capable of holding a process identifier. */ #undef pid_t /* Define to `unsigned int' if <sys/types.h> does not define. */ #undef size_t /* Define as int if socklen_t is not available */ #undef socklen_t /* Define to `int' if <sys/types.h> doesn't define. */ #undef uid_t |
| ︙ | ︙ |
Changes to unix/tclConfig.sh.in.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # TCL_DBGX used to be used to distinguish debug vs. non-debug builds. # This was a righteous pain so the core doesn't do that any more. | > | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # TCL_DBGX used to be used to distinguish debug vs. non-debug builds. # This was a righteous pain so the core doesn't do that any more. # DEPRECATED, will be removed in Tcl 9! TCL_DBGX='' # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' |
| ︙ | ︙ |
Changes to unix/tclEpollNotfy.c.
1 2 3 4 5 6 7 | /* * tclEpollNotfy.c -- * * This file contains the implementation of the epoll()-based * Linux-specific notifier, which is the lowest-level part of the Tcl * event loop. This file works together with generic/tclNotify.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 | /* * tclEpollNotfy.c -- * * This file contains the implementation of the epoll()-based * Linux-specific notifier, which is the lowest-level part of the Tcl * event loop. This file works together with generic/tclNotify.c. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_EPOLL) && TCL_THREADS #ifndef _GNU_SOURCE # define _GNU_SOURCE /* For pipe2(2) */ #endif #include <fcntl.h> #include <signal.h> #include <sys/epoll.h> #ifdef HAVE_EVENTFD #include <sys/eventfd.h> #endif /* HAVE_EVENTFD */ #include <sys/queue.h> |
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | * Finalize is called. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* Finalize is called.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
PlatformEventsFinalize();
}
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
| | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
newEvent.data.ptr = filePtr->pedPtr;
/*
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
}
| | | | 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 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
}
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
#ifdef HAVE_EVENTFD
tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
if (tsdPtr->triggerEventFd <= 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger eventfd");
}
filePtr->fd = tsdPtr->triggerEventFd;
#else /* !HAVE_EVENTFD */
if (pipe2(tsdPtr->triggerPipe, O_CLOEXEC | O_NONBLOCK) != 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
}
filePtr->fd = tsdPtr->triggerPipe[0];
#endif /* HAVE_EVENTFD */
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 *)ckalloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
* which in turn will cause PlatformEventsWait() to return
* immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
| | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
* which in turn will cause PlatformEventsWait() to return
* immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
pedPtr = (struct PlatformEventData*)tsdPtr->readyEvents[numEvent].data.ptr;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
#ifdef HAVE_EVENTFD
if (filePtr->fd == tsdPtr->triggerEventFd) {
uint64_t eventFdVal;
i = read(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal));
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
|
| ︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
1 2 3 4 5 6 7 8 | /* * tclKqueueNotfy.c -- * * This file contains the implementation of the kqueue()-based * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest- * level part of the Tcl event loop. This file works together with * generic/tclNotify.c. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclKqueueNotfy.c -- * * This file contains the implementation of the kqueue()-based * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest- * level part of the Tcl event loop. This file works together with * generic/tclNotify.c. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | * Finalize is called. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
* Finalize is called.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
PlatformEventsFinalize();
}
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
{
int numChanges;
struct kevent changeList[2];
struct PlatformEventData *newPedPtr;
struct stat fdStat;
if (isNew) {
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
{
int numChanges;
struct kevent changeList[2];
struct PlatformEventData *newPedPtr;
struct stat fdStat;
if (isNew) {
newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
/*
* N.B. As discussed in Tcl_WaitForEvent(), kqueue(2) does not reproduce
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
| | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = tsdPtr->triggerPipe[0];
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = (struct kevent *)ckalloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask |= mask;
|
| ︙ | ︙ |
Changes to unix/tclLoadAix.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclLoadAix.c -- * * This file implements the dlopen and dlsym APIs under the AIX operating * system, to enable the Tcl "load" command to work. This code was * provided by Jens-Uwe Mager. * * This file is subject to the following copyright notice, which is * different from the notice used elsewhere in Tcl. The file has been * modified to incorporate the file dlfcn.h in-line. * | | | | 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 | /* * tclLoadAix.c -- * * This file implements the dlopen and dlsym APIs under the AIX operating * system, to enable the Tcl "load" command to work. This code was * provided by Jens-Uwe Mager. * * This file is subject to the following copyright notice, which is * different from the notice used elsewhere in Tcl. The file has been * modified to incorporate the file dlfcn.h in-line. * * Copyright © 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH * Not derived from licensed software. * * Permission is granted to freely use, copy, modify, and redistribute * this software, provided that the author is not construed to be liable * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * * Note: this file has been altered from the original in a few ways in order * to work properly with Tcl. */ /* * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 * This is an unpublished work copyright © 1992 HELIOS Software GmbH * 30159 Hannover, Germany */ #include <stdio.h> #include <errno.h> #include <string.h> #include <stdlib.h> |
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
1 2 3 4 5 6 | /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "dlopen" and "dlsym" library procedures for dynamic loading. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "dlopen" and "dlsym" library procedures for dynamic loading. * * 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" #ifdef NO_DLFCN_H |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
/*
* 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.
*/
| | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
/*
* 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.
*/
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;
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
if (interp) {
if (!errorStr) {
errorStr = "unknown";
| > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
#ifdef __cplusplus
if (proc == NULL) {
char buf[32];
sprintf(buf, "%d", Tcl_DStringLength(&ds));
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "__Z");
Tcl_DStringAppend(&newName, buf, -1);
Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), -1);
TclDStringAppendLiteral(&newName, "P10Tcl_Interp");
native = Tcl_DStringValue(&newName);
proc = dlsym(handle, native + 1); /* INTL: Native. */
if (proc == NULL) {
proc = dlsym(handle, native); /* INTL: Native. */
}
if (proc == NULL) {
TclDStringAppendLiteral(&newName, "i");
native = Tcl_DStringValue(&newName);
proc = dlsym(handle, native + 1); /* INTL: Native. */
}
if (proc == NULL) {
proc = dlsym(handle, native); /* INTL: Native. */
}
Tcl_DStringFree(&newName);
}
#endif
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
if (interp) {
if (!errorStr) {
errorStr = "unknown";
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
ckfree(loadHandle);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadDyld.c.
1 2 3 4 5 6 7 8 | /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that works with * Apple's dyld dynamic loading. * Original version of his file (superseded long ago) provided by * Wilfredo Sanchez (wsanchez@apple.com). * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that works with * Apple's dyld dynamic loading. * Original version of his file (superseded long ago) provided by * Wilfredo Sanchez (wsanchez@apple.com). * * Copyright © 1995 Apple Computer, Inc. * Copyright © 2001-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
179 180 181 182 183 184 185 |
/*
* 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.
*/
| | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
/*
* 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);
nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
-1, &ds);
#if TCL_DYLD_USE_DLFCN
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
| | | | | > | 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 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
if (dlHandle
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
#endif /* TCL_DYLD_USE_NSMODULE */
) {
dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = dlHandle;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
newHandle = (Tcl_LoadHandle)ckalloc(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, -1);
}
#if TCL_DYLD_USE_NSMODULE
if (objFileImageErrMsg) {
Tcl_AppendPrintfToObj(errObj,
"\nNSCreateObjectFileImageFromFile() error: %s",
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
static void *
FindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
| | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
static void *
FindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
proc = (Tcl_PackageInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
| | | | | 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 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
}
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
}
} else if (dyldLoadHandle->modulePtr) {
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
proc = (Tcl_PackageInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
}
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,
NULL);
}
return (void *)proc;
}
/*
*----------------------------------------------------------------------
*
* UnloadFile --
*
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
static void
UnloadFile(
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) {
#if TCL_DYLD_USE_DLFCN
(void) dlclose(dyldLoadHandle->dlHandle);
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
ckfree(dyldLoadHandle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
ckfree(dyldLoadHandle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclpLoadMemoryGetBuffer --
*
* Allocate a buffer that can be used with TclpLoadMemory() below.
*
* Results:
* Pointer to allocated buffer or NULL if an error occurs.
*
* Side effects:
* Buffer is allocated.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
TCL_UNUSED(Tcl_Interp *),
int size) /* Size of desired buffer. */
{
void *buffer = NULL;
/*
* NSCreateObjectFileImageFromMemory is available but always fails
* prior to Darwin 7.
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
| | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
const struct fat_header *fh = (const struct fat_header *)buffer;
uint32_t ms = 0;
#ifndef __LP64__
const struct mach_header *mh = NULL;
# define mh_size sizeof(struct mach_header)
# define mh_magic MH_MAGIC
# define arch_abi 0
#else
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
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) {
| | | | | | | 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 |
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);
}
fa = NXFindBestFatArch(arch->cputype | arch_abi,
arch->cpusubtype, (struct fat_arch *)fatarchs, fh_nfat_arch);
if (fa) {
mh = (const struct mach_header_64 *)((char *) buffer + fa->offset);
ms = fa->size;
} else {
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
err = NSObjectFileImageInappropriateFile;
}
} else {
/*
* Thin binary
*/
mh = (const struct mach_header_64 *)buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
| | | | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = NULL;
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
1 2 3 4 5 6 | /* * tclLoadNext.c -- * * This procedure provides a version of the TclLoadFile that works with * NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclLoadNext.c -- * * This procedure provides a version of the TclLoadFile that works with * NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich. * * 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 <mach-o/rld.h> |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
| | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | * includes: MK6, MK7, AD2, AD3 (from OSF RI) * * This approach to things was utter @&^#; thankfully, OSF/1 eventually * supported dlopen(). * * John Robert LoVerso <loverso@freebsd.osf.org> * | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * includes: MK6, MK7, AD2, AD3 (from OSF RI) * * This approach to things was utter @&^#; thankfully, OSF/1 eventually * supported dlopen(). * * John Robert LoVerso <loverso@freebsd.osf.org> * * 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 <sys/types.h> |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
| | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = pkg;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadShl.c.
1 2 3 4 5 6 7 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "shl_load" and "shl_findsym" library procedures for dynamic * loading (e.g. for HP machines). * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "shl_load" and "shl_findsym" library procedures for dynamic * loading (e.g. for HP machines). * * 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 <dl.h> #include "tclInt.h" |
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
| | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
ckfree(loadHandle);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclSelectNotfy.c.
1 2 3 4 5 6 7 | /* * tclSelectNotfy.c -- * * This file contains the implementation of the select()-based generic * Unix notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclSelectNotfy.c -- * * This file contains the implementation of the select()-based generic * Unix notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. * * 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" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is |
| ︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 |
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of critical bits of Windows API when building threaded with Cygwin.
*/
#if defined(__CYGWIN__)
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
| > > > | | > | | | | | | | > > > | 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 |
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of critical bits of Windows API when building threaded with Cygwin.
*/
#if defined(__CYGWIN__)
#ifdef __cplusplus
extern "C" {
#endif
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
size_t wParam; /* Event-specific "word" parameter. */
size_t lParam; /* Event-specific "long" parameter. */
int time; /* Event timestamp. */
int x; /* Event location (where meaningful). */
int y;
int lPrivate;
} MSG;
typedef struct {
unsigned int style;
void *lpfnWndProc;
int cbClsExtra;
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
const void *lpszMenuName;
const void *lpszClassName;
} WNDCLASSW;
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
unsigned int, int, int, int, int, void *, void *, void *,
void *);
extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall DestroyWindow(void *);
extern int __stdcall DispatchMessageW(const MSG *);
extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *,
unsigned char, unsigned int, unsigned int);
extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
void *);
extern void __stdcall PostQuitMessage(int);
extern void *__stdcall RegisterClassW(const WNDCLASSW *);
extern unsigned char __stdcall ResetEvent(void *);
extern unsigned char __stdcall TranslateMessage(const MSG *);
/*
* Threaded-cygwin specific constants and functions in this file:
*/
static const wchar_t className[] = L"TclNotifier";
static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
void *wParam, void *lParam);
#ifdef __cplusplus
}
#endif
#endif /* TCL_THREADS && __CYGWIN__ */
#include "tclUnixNotfy.c"
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
| | | | | | | | | | | | | | | | | 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 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
WNDCLASSW clazz;
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);
tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
0 /* !signaled */, NULL);
#else
pthread_cond_init(&tsdPtr->waitCV, NULL);
#endif /* __CYGWIN__ */
tsdPtr->waitCVinitialized = 1;
}
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
#if TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
}
ckfree(filePtr);
}
}
#if defined(__CYGWIN__)
| | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
}
ckfree(filePtr);
}
}
#if defined(__CYGWIN__)
static unsigned int __stdcall
NotifierProc(
void *hwnd,
unsigned int message,
void *wParam,
void *lParam)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
| > < | 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 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
/*
* Set up the timeout structure. Note that if there are no events to
* check for, we return with a negative result rather than blocking
* forever.
*/
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
| | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
unsigned int timeout;
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
timeout = 0xFFFFFFFF;
}
pthread_mutex_unlock(¬ifierMutex);
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
| | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
unsigned int result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
PostQuitMessage(msg.wParam);
/* What to do here? */
} else if (result != (unsigned int) -1) {
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
}
ResetEvent(tsdPtr->event);
#endif /* __CYGWIN__ */
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
(FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 | * *---------------------------------------------------------------------- */ #if TCL_THREADS static TCL_NORETURN void NotifierThreadProc( | | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
fd_set exceptionMask;
int i;
int fds[2], receivePipe;
long found;
struct timeval poll = {0, 0}, *timePtr;
char buf[2];
int numFdBits = 0;
if (pipe(fds) != 0) {
Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe");
}
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
1 2 3 4 5 6 | /* * tclUnixChan.c * * Common channel driver for Unix channels based on files, command pipes * and TCP sockets. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclUnixChan.c * * Common channel driver for Unix channels based on files, command pipes * and TCP sockets. * * Copyright © 1995-1997 Sun Microsystems, Inc. * 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. */ |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
* Static routines for this file:
*/
| | | | | | | | > | > | | | | | | | | > > > > | | | | 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 |
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
* Static routines for this file:
*/
static int FileBlockModeProc(void *instanceData, int mode);
static int FileCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static int FileGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int FileInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int FileSeekProc(void *instanceData, long offset,
int mode, int *errorCode);
#endif
static int FileTruncateProc(void *instanceData,
Tcl_WideInt length);
static Tcl_WideInt FileWideSeekProc(void *instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
static void FileWatchProc(void *instanceData, int mask);
#ifdef SUPPORTS_TTY
static int TtyCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr);
static int TtyGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int TtyGetBaud(speed_t speed);
static speed_t TtyGetSpeed(int baud);
static void TtyInit(int fd);
static void TtyModemStatusStr(int status, Tcl_DString *dsPtr);
static int TtyParseMode(Tcl_Interp *interp, const char *mode,
TtyAttrs *ttyPtr);
static void TtySetAttributes(int fd, TtyAttrs *ttyPtr);
static int TtySetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
#endif /* SUPPORTS_TTY */
/*
* This structure describes the channel type structure for file based IO:
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
#else
NULL,
#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
FileCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* wide seek proc. */
NULL,
FileTruncateProc /* truncate proc. */
};
#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", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TtySetOptionProc, /* Set option proc. */
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
TtyCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
NULL, /* thread action proc. */
NULL /* truncate proc. */
};
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 | * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ | < | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
*
* Side effects:
* 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;
}
return 0;
}
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | | | 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 |
* 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
* input device? */
*errorCodePtr = 0;
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block.
*/
bytesRead = read(fsPtr->fd, buf, (size_t) toRead);
if (bytesRead >= 0) {
return bytesRead;
}
*errorCodePtr = errno;
return -1;
}
/*
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | | | 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 |
* 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;
*errorCodePtr = 0;
if (toWrite == 0) {
/*
* SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM
* based implementations will considers this as EOF (if there is a
* pipe behind the file).
*/
return 0;
}
written = write(fsPtr->fd, buf, (size_t) toWrite);
if (written >= 0) {
return written;
}
*errorCodePtr = errno;
return -1;
}
/*
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | > | > > > > | | > | > > > | 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 |
* 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) {
return EINVAL;
}
Tcl_DeleteFileHandler(fsPtr->fd);
/*
* Do not close standard channels while in thread-exit.
*/
if (!TclInThreadExit()
|| ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) {
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
ckfree(fsPtr);
return errorCode;
}
#ifdef SUPPORTS_TTY
static int
TtyCloseProc(
void *instanceData,
Tcl_Interp *interp,
int flags)
{
TtyState *ttyPtr = (TtyState*)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* If we've been asked by the user to drain or flush, do so now.
*/
switch (ttyPtr->closeMode) {
case CLOSE_DRAIN:
tcdrain(ttyPtr->fileState.fd);
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
| | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
return FileCloseProc(instanceData, interp, flags);
}
#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 | * * Side effects: * Moves the location at which the channel will be accessed in future * operations. * *---------------------------------------------------------------------- */ | | | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
*
* Side effects:
* Moves the location at which the channel will be accessed in future
* operations.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
void *instanceData, /* File state. */
long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_SET or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == -1) ? errno : 0;
}
return (int) newLoc;
}
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* This function is called by the generic IO level to move the access
| > | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == -1) ? errno : 0;
}
return (int) newLoc;
}
#endif
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* This function is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 | * operations. * *---------------------------------------------------------------------- */ static Tcl_WideInt FileWideSeekProc( | | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* operations.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
FileWideSeekProc(
void *instanceData, /* File state. */
Tcl_WideInt 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;
Tcl_WideInt newLoc;
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
*errorCodePtr = (newLoc == -1) ? errno : 0;
return newLoc;
}
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | * be seen by Tcl. * *---------------------------------------------------------------------- */ static void FileWatchProc( | | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
* be seen by Tcl.
*
*----------------------------------------------------------------------
*/
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;
/*
* Make sure we only register for events that are valid on this file. Note
* that we are passing Tcl_NotifyChannel directly to Tcl_CreateFileHandler
* with the channel pointer as the client data.
*/
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
* 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;
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( | | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
* 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;
unsigned int len, vlen;
TtyAttrs tty;
int argc;
const char **argv;
struct termios iostate;
len = strlen(optionName);
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( | | | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
* (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;
unsigned int len;
char buf[3*TCL_INTEGER_SPACE + 16];
int valid = 0; /* Flag if valid option parsed. */
struct termios iostate;
if (optionName == NULL) {
len = 0;
|
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 |
* This may occurr if modeString was "", for example.
*/
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
| | | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 |
* This may occurr if modeString was "", for example.
*/
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",
NULL);
}
return NULL;
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 |
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
| | | 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 |
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fileState.fd = fd;
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel( | | | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
|
| ︙ | ︙ | |||
1786 1787 1788 1789 1790 1791 1792 |
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0)
&& (sockaddrLen > 0)
&& (sockaddr.sa_family == AF_INET
|| sockaddr.sa_family == AF_INET6)) {
| | | | 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 |
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0)
&& (sockaddrLen > 0)
&& (sockaddr.sa_family == AF_INET
|| sockaddr.sa_family == AF_INET6)) {
return (Tcl_Channel)TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
} else {
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
fsPtr->fileState.fd = fd;
fsPtr->fileState.validMask = mode | TCL_EXCEPTION;
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, mode);
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
|
| ︙ | ︙ | |||
1923 1924 1925 1926 1927 1928 1929 |
int
Tcl_GetOpenFile(
Tcl_Interp *interp, /* Interpreter in which to find file. */
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
| | < | | | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 |
int
Tcl_GetOpenFile(
Tcl_Interp *interp, /* Interpreter in which to find file. */
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)) {
|
| ︙ | ︙ | |||
2018 2019 2020 2021 2022 2023 2024 | * places later in the file than the truncate point. * *---------------------------------------------------------------------- */ static int FileTruncateProc( | | | | 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 |
* places later in the file than the truncate point.
*
*----------------------------------------------------------------------
*/
static int
FileTruncateProc(
void *instanceData,
Tcl_WideInt length)
{
FileState *fsPtr = (FileState *)instanceData;
int result;
#ifdef HAVE_TYPE_OFF64_T
/*
* We assume this goes with the type for now...
*/
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER | | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER static void FreePwBuf(ClientData dummy); #endif #ifdef NEED_GR_CLEANER static void FreeGrBuf(ClientData dummy); #endif #endif /* TCL_THREADS */ /* *--------------------------------------------------------------------------- * * TclUnixSetBlockingMode -- |
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
| | | | 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 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
| | | | 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 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 | * *--------------------------------------------------------------------------- */ #ifdef NEED_PW_CLEANER static void FreePwBuf( | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ckfree(tsdPtr->pbuf);
}
#endif /* NEED_PW_CLEANER */
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | | 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 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | | 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 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char *)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 | * *--------------------------------------------------------------------------- */ #ifdef NEED_GR_CLEANER static void FreeGrBuf( | | | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ckfree(tsdPtr->gbuf);
}
#endif /* NEED_GR_CLEANER */
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 |
{
#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYNAME)
return gethostbyname(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYNAME_R_5)
| | | | | | 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 !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYNAME)
return gethostbyname(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYNAME_R_5)
int local_errno;
return gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &local_errno);
#elif defined(HAVE_GETHOSTBYNAME_R_6)
struct hostent *hePtr = NULL;
int local_errno, result;
result = gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &hePtr, &local_errno);
return (result == 0) ? hePtr : NULL;
#elif defined(HAVE_GETHOSTBYNAME_R_3)
struct hostent_data data;
return (gethostbyname_r(name, &tsdPtr->hent, &data) == 0)
? &tsdPtr->hent : NULL;
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
{
#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYADDR)
return gethostbyaddr(addr, length, type);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYADDR_R_7)
| | | | | | 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 |
{
#if !TCL_THREADS || defined(HAVE_MTSAFE_GETHOSTBYADDR)
return gethostbyaddr(addr, length, type);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYADDR_R_7)
int local_errno;
return gethostbyaddr_r(addr, length, type, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &local_errno);
#elif defined(HAVE_GETHOSTBYADDR_R_8)
struct hostent *hePtr;
int local_errno;
return (gethostbyaddr_r(addr, length, type, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &hePtr, &local_errno) == 0)
? &tsdPtr->hent : NULL;
#else
#define NEED_COPYHOSTENT 1
struct hostent *hePtr;
Tcl_MutexLock(&compatLock);
hePtr = gethostbyaddr(addr, length, type);
|
| ︙ | ︙ | |||
899 900 901 902 903 904 905 |
*/
}
len = sizeof(char *) * (i + 1); /* Leave place for the array. */
if (len > buflen) {
return -1;
}
| | | 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 |
*/
}
len = sizeof(char *) * (i + 1); /* Leave place for the array. */
if (len > buflen) {
return -1;
}
newBuffer = (char **)buf;
p = buf + len;
for (j = 0; j < i; j++) {
int sz = (elsize<0 ? (int) strlen(src[j]) + 1 : elsize);
len += sz;
if (len > buflen) {
|
| ︙ | ︙ |
Changes to unix/tclUnixEvent.c.
1 2 3 4 5 | /* * tclUnixEvent.c -- * * This file implements Unix specific event related routines. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixEvent.c -- * * This file implements Unix specific event related routines. * * Copyright © 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" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is |
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
1 2 3 4 5 6 7 | /* * tclUnixFCmd.c * * This file implements the unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | /* * tclUnixFCmd.c * * This file implements the unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Portions of this code were derived from NetBSD source code which has the * following copyright notice: * * Copyright © 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | * Constants and variables necessary for file attributes subcommand. * * IMPORTANT: The permissions attribute is assumed to be the third item (i.e. * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly * elsewhere in Tcl's core. */ | | < < < < < < < < | < | 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 |
* Constants and variables necessary for file attributes subcommand.
*
* IMPORTANT: The permissions attribute is assumed to be the third item (i.e.
* to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly
* elsewhere in Tcl's core.
*/
#ifndef DJGPP
enum {
#if defined(__CYGWIN__)
UNIX_ARCHIVE_ATTRIBUTE,
#endif
UNIX_GROUP_ATTRIBUTE,
#if defined(__CYGWIN__)
UNIX_HIDDEN_ATTRIBUTE,
#endif
UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
UNIX_READONLY_ATTRIBUTE,
#endif
#if defined(__CYGWIN__)
UNIX_SYSTEM_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
UNIX_INVALID_ATTRIBUTE
};
const char *const tclpFileAttrStrings[] = {
#if defined(__CYGWIN__)
"-archive",
#endif
"-group",
#if defined(__CYGWIN__)
"-hidden",
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
#endif
#ifdef MAC_OSX_TCL
"-creator", "-type", "-hidden", "-rsrclength",
#endif
NULL
};
| < | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
#endif
#ifdef MAC_OSX_TCL
"-creator", "-type", "-hidden", "-rsrclength",
#endif
NULL
};
const TclFileAttrProcs tclpFileAttrProcs[] = {
#if defined(__CYGWIN__)
{GetUnixFileAttributes, SetUnixFileAttributes},
#endif
{GetGroupAttribute, SetGroupAttribute},
#if defined(__CYGWIN__)
{GetUnixFileAttributes, SetUnixFileAttributes},
|
| ︙ | ︙ | |||
327 328 329 330 331 332 333 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoRenameFile((const char *)Tcl_FSGetNativePath(srcPathPtr),
(const char *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
const char *src, /* Pathname of file or dir to be renamed
* (native). */
const char *dst) /* New pathname of file or directory
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
const char *src = (const char *)Tcl_FSGetNativePath(srcPathPtr);
Tcl_StatBuf srcStatBuf;
if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
return DoCopyFile(src, (const char *)Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
}
static int
DoCopyFile(
const char *src, /* Pathname of file to be copied (native). */
const char *dst, /* Pathname of file to copy to (native). */
const Tcl_StatBuf *statBufPtr)
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
| | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
buffer = (char *)ckalloc(blockSize);
while (1) {
nread = (size_t) read(srcFd, buffer, blockSize);
if ((nread == (size_t) -1) || (nread == 0)) {
break;
}
if ((size_t) write(dstFd, buffer, nread) != nread) {
nread = (size_t) -1;
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
| | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
return DoCreateDirectory((const char *)Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const char *path) /* Pathname of directory to create (native). */
{
mode_t mode;
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
const char *paths[2] = {NULL, NULL};
FTS *fts = NULL;
FTSENT *ent;
#endif
errfile = NULL;
result = TCL_OK;
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
const char *paths[2] = {NULL, NULL};
FTS *fts = NULL;
FTSENT *ent;
#endif
errfile = NULL;
result = TCL_OK;
targetLen = 0;
source = Tcl_DStringValue(sourcePtr);
if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
errfile = source;
goto end;
}
if (!S_ISDIR(statBuf.st_mode)) {
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
Tcl_DString *srcPtr, /* Source pathname (native). */
| | | < > | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
Tcl_DString *srcPtr, /* Source pathname (native). */
TCL_UNUSED(Tcl_DString *),
TCL_UNUSED(const Tcl_StatBuf *),
int type, /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
return TCL_OK;
}
break;
case DOTREE_PRED:
|
| ︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 | * access time are updated in the new file to reflect the old file. * *--------------------------------------------------------------------------- */ static int CopyFileAtts( | > | > > > | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 |
* access time are updated in the new file to reflect the old file.
*
*---------------------------------------------------------------------------
*/
static int
CopyFileAtts(
#ifdef MAC_OSX_TCL
const char *src, /* Path name of source file (native). */
#else
TCL_UNUSED(const char *) /*src*/,
#endif
const char *dst, /* Path name of target file (native). */
const Tcl_StatBuf *statBufPtr)
/* Stat info for source file */
{
struct utimbuf tval;
mode_t newMode;
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
*
*----------------------------------------------------------------------
*/
static int
GetGroupAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
*
*----------------------------------------------------------------------
*/
static int
GetGroupAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
struct group *groupPtr;
int result;
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
}
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
| | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
}
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (groupPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_gid);
} else {
Tcl_DString ds;
const char *utf;
utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
*attributePtrPtr = Tcl_NewStringObj(utf, -1);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 |
*
*----------------------------------------------------------------------
*/
static int
GetOwnerAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
*
*----------------------------------------------------------------------
*/
static int
GetOwnerAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
struct passwd *pwPtr;
int result;
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 |
}
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
| | | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
}
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (pwPtr == NULL) {
TclNewIntObj(*attributePtrPtr, statBuf.st_uid);
} else {
Tcl_DString ds;
(void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
*attributePtrPtr = TclDStringToObj(&ds);
}
return TCL_OK;
|
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 |
*
*----------------------------------------------------------------------
*/
static int
GetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
*
*----------------------------------------------------------------------
*/
static int
GetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
*
*---------------------------------------------------------------------------
*/
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
| | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 |
*
*---------------------------------------------------------------------------
*/
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New group for file. */
{
Tcl_WideInt gid;
int result;
const char *native;
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
"NO_GROUP", NULL);
}
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
| | | 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 |
"NO_GROUP", NULL);
}
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
1557 1558 1559 1560 1561 1562 1563 |
*
*---------------------------------------------------------------------------
*/
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
| | | 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 |
*
*---------------------------------------------------------------------------
*/
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New owner for file. */
{
Tcl_WideInt uid;
int result;
const char *native;
|
| ︙ | ︙ | |||
1590 1591 1592 1593 1594 1595 1596 |
"NO_USER", NULL);
}
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
| | | 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 |
"NO_USER", NULL);
}
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
*
*---------------------------------------------------------------------------
*/
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
*
*---------------------------------------------------------------------------
*/
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
Tcl_WideInt mode;
mode_t newMode;
int result = TCL_ERROR;
const char *native;
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
}
}
| | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 |
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
}
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set permissions for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
|
| ︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | * See the user documentation. * *---------------------------------------------------------------------- */ static int GetModeFromPermString( | | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
GetModeFromPermString(
TCL_UNUSED(Tcl_Interp *),
const char *modeStringPtr, /* Permissions string */
mode_t *modePtr) /* pointer to the mode value */
{
mode_t newMode;
mode_t oldMode; /* Storage for the value of the old mode (that
* is passed in), to allow for the chmod style
* manipulation. */
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
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':
| | | | | 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 |
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;
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': what |= 0xC00; continue; case 't': what |= 0x200; continue; case ',': break; default: |
| ︙ | ︙ | |||
1932 1933 1934 1935 1936 1937 1938 | * Side effects: * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath( | | | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 |
* Side effects:
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize. */
int nextCheckpoint) /* offset to start at in pathPtr. Must either
* be 0 or the offset of a directory separator
* at the end of a path part that is already
* normalized. I.e. this is not the index of
* the byte just after the separator. */
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 |
#ifndef NO_REALPATH
if (nextCheckpoint == 0 && haveRealpath) {
/*
* Try to get the entire path in one go
*/
| | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
#ifndef NO_REALPATH
if (nextCheckpoint == 0 && haveRealpath) {
/*
* Try to get the entire path in one go
*/
const char *lastDir = strrchr(currentPathEndPosition, '/');
if (lastDir != NULL) {
nativePath = Tcl_UtfToExternalDString(NULL, path,
lastDir-path, &ds);
if (Realpath(nativePath, normPath) != NULL) {
if (*nativePath != '/' && *normPath == '/') {
/*
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 |
int
TclUnixOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
| | | | | | | | | | | | | | | | | | 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 |
int
TclUnixOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
Tcl_DString templ, tmp;
const char *string;
int fd;
/*
* We should also check against making more then TMP_MAX of these.
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */
}
TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
string = TclGetString(basenameObj);
Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, "tcl");
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
string = TclGetString(extensionObj);
Tcl_UtfToExternalDString(NULL, string, extensionObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else
#endif
{
fd = mkstemp(Tcl_DStringValue(&templ));
}
if (fd == -1) {
Tcl_DStringFree(&templ);
return -1;
}
if (resultingNameObj) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
Tcl_DStringLength(&templ), &tmp);
Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp),
Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else {
/*
* Try to delete the file immediately since we're not reporting the
* name to anyone. Note that we're *not* handling any errors from
* this!
*/
unlink(Tcl_DStringValue(&templ));
errno = 0;
}
Tcl_DStringFree(&templ);
return fd;
}
/*
* Helper that does *part* of what tempnam() does.
*/
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 |
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
| | | | | | | | | | | | | | | | | 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 |
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
Tcl_DString templ, tmp;
const char *string;
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
/*
* Build the template in writable memory from the user-supplied pieces and
* some defaults.
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */
}
if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') {
TclDStringAppendLiteral(&templ, "/");
}
if (basenameObj) {
string = TclGetString(basenameObj);
if (basenameObj->length) {
Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
}
} else {
TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
/*
* Make the temporary directory.
*/
if (mkdtemp(Tcl_DStringValue(&templ)) == NULL) {
Tcl_DStringFree(&templ);
return NULL;
}
/*
* The template has been updated. Tell the caller what it was.
*/
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
Tcl_DStringLength(&templ), &tmp);
Tcl_DStringFree(&templ);
return TclDStringToObj(&tmp);
}
#if defined(__CYGWIN__)
static void
StatError(
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 |
}
static WCHAR *
winPathFromObj(
Tcl_Obj *fileName)
{
int size;
| | | | 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 |
}
static WCHAR *
winPathFromObj(
Tcl_Obj *fileName)
{
int size;
const char *native = (const char *)Tcl_FSGetNativePath(fileName);
WCHAR *winPath;
size = cygwin_conv_path(1, native, NULL, 0);
winPath = (WCHAR *)ckalloc(size);
cygwin_conv_path(1, native, winPath, size);
return winPath;
}
static const int attributeArray[] = {
0x20, 0, 2, 0, 0, 1, 4
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
ckfree(winPath);
if (fileAttributes == -1) {
StatError(interp, fileName);
return TCL_ERROR;
}
| | | 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 |
ckfree(winPath);
if (fileAttributes == -1) {
StatError(interp, fileName);
return TCL_ERROR;
}
TclNewIntObj(*attributePtrPtr,
(fileAttributes & attributeArray[objIndex]) != 0);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 |
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | | 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 |
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
TclNewIntObj(*attributePtrPtr, (statBuf.st_flags & UF_IMMUTABLE) != 0);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* SetUnixFileAttributes
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 |
*
*---------------------------------------------------------------------------
*/
static int
SetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
*
*---------------------------------------------------------------------------
*/
static int
SetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
Tcl_StatBuf statBuf;
int result, readonly;
const char *native;
|
| ︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 |
if (readonly) {
statBuf.st_flags |= UF_IMMUTABLE;
} else {
statBuf.st_flags &= ~UF_IMMUTABLE;
}
| | | 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 |
if (readonly) {
statBuf.st_flags |= UF_IMMUTABLE;
} else {
statBuf.st_flags &= ~UF_IMMUTABLE;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chflags(native, statBuf.st_flags); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set flags for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
1 2 3 4 5 6 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * Copyright © 1995-1998 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 "tclFileSystem.h" |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 | * * Side effects: * The computed path name is stored as a ProcessGlobalValue. * *--------------------------------------------------------------------------- */ void TclpFindExecutable( | > | < < > > > > > > > > | 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 |
*
* Side effects:
* The computed path name is stored as a ProcessGlobalValue.
*
*---------------------------------------------------------------------------
*/
#ifdef __CYGWIN__
void
TclpFindExecutable(
TCL_UNUSED(const char *) /*argv0*/)
{
Tcl_Encoding encoding;
int length;
wchar_t buf[PATH_MAX];
char name[PATH_MAX * 3 + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
length -= 4;
}
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
}
#else
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
if (argv0 == NULL) {
return;
}
|
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
| | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
while (TclIsSpaceProcM(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
| < > | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
}
#endif
/*
*----------------------------------------------------------------------
*
* TclpMatchInDirectory --
*
* This routine is used by the globbing code to search a directory for
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | /* * Match a file directly. */ Tcl_Obj *tailPtr; const char *nativeTail; | | | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
const char *nativeTail;
native = (const char *)Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = (const char *)Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
|
| ︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
&buf, types);
if (matchResult != 1) {
return matchResult;
}
}
#endif /* MAC_OSX_TCL */
return 1;
}
/*
*---------------------------------------------------------------------------
| > > | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
&buf, types);
if (matchResult != 1) {
return matchResult;
}
}
#else
(void)interp;
#endif /* MAC_OSX_TCL */
return 1;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
*/
int
TclpObjAccess(
Tcl_Obj *pathPtr, /* Path of file to access */
int mode) /* Permission setting. */
{
| | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
*/
int
TclpObjAccess(
Tcl_Obj *pathPtr, /* Path of file to access */
int mode) /* Permission setting. */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return access(path, mode);
}
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
*---------------------------------------------------------------------------
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory */
{
| | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
*---------------------------------------------------------------------------
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return chdir(path);
}
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
*/
int
TclpObjLstat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
| | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
*/
int
TclpObjLstat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
return TclOSlstat((const char *)Tcl_FSGetNativePath(pathPtr), bufPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpGetNativeCwd --
*
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
| | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = (char*)ckalloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
}
/*
* No change to pwd.
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
*/
int
TclpObjStat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
| | | | 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 |
*/
int
TclpObjStat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return TclOSstat(path, bufPtr);
}
#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = (const char *)Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
| | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = (const char*)Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
| | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = TclDStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclpFilesystemPathType( | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclpFilesystemPathType(
TCL_UNUSED(Tcl_Obj *))
{
/*
* All native paths are of the same type.
*/
return NULL;
}
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
| | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = (char *)ckalloc(len);
memcpy(nativePathPtr, Tcl_DStringValue(&ds), len);
Tcl_DStringFree(&ds);
return nativePathPtr;
}
/*
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
| | | 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
*/
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
| | | | 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 |
*/
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
return utime((const char *)Tcl_FSGetNativePath(pathPtr), tval);
}
#ifdef __CYGWIN__
int
TclOSstat(
const char *name,
void *cygstat)
{
struct stat buf;
Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = stat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 |
int
TclOSlstat(
const char *name,
void *cygstat)
{
struct stat buf;
| | | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 |
int
TclOSlstat(
const char *name,
void *cygstat)
{
struct stat buf;
Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = lstat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
1 2 3 4 5 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * 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> # ifdef __APPLE__ |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
# include <sys/param.h>
# if _BSDI_VERSION > 199501
# include <dlfcn.h>
# endif
#endif
#ifdef __CYGWIN__
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *);
DLLIMPORT extern __stdcall void FreeLibrary(void *);
DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
typedef struct {
union {
| > > > > > > | | | | | | | | | | | 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 |
# include <sys/param.h>
# if _BSDI_VERSION > 199501
# include <dlfcn.h>
# endif
#endif
#ifdef __CYGWIN__
#ifdef __cplusplus
extern "C" {
#endif
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *);
DLLIMPORT extern __stdcall void FreeLibrary(void *);
DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
#ifdef __cplusplus
}
#endif
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
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
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
| | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
{"", "iso8859-1"},
{"ansi-1251", "cp1251"},
{"ansi_x3.4-1968", "iso8859-1"},
{"ascii", "ascii"},
{"big5", "big5"},
{"cp1250", "cp1250"},
{"cp1251", "cp1251"},
{"cp1252", "cp1252"},
{"cp1253", "cp1253"},
{"cp1254", "cp1254"},
|
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
{"eucjp", "euc-jp"},
{"euckr", "euc-kr"},
{"euctw", "euc-cn"},
{"gb12345", "gb12345"},
{"gb1988", "gb1988"},
{"gb2312", "gb2312"},
{"gb2312-1980", "gb2312"},
{"gb2312-raw", "gb2312-raw"},
{"greek8", "cp869"},
{"ibm1250", "cp1250"},
{"ibm1251", "cp1251"},
{"ibm1252", "cp1252"},
{"ibm1253", "cp1253"},
{"ibm1254", "cp1254"},
{"ibm1255", "cp1255"},
{"ibm1256", "cp1256"},
{"ibm1257", "cp1257"},
{"ibm1258", "cp1258"},
{"ibm437", "cp437"},
{"ibm737", "cp737"},
{"ibm775", "cp775"},
{"ibm850", "cp850"},
{"ibm852", "cp852"},
{"ibm855", "cp855"},
{"ibm857", "cp857"},
{"ibm860", "cp860"},
{"ibm861", "cp861"},
{"ibm862", "cp862"},
{"ibm863", "cp863"},
{"ibm864", "cp864"},
{"ibm865", "cp865"},
{"ibm866", "cp866"},
{"ibm869", "cp869"},
{"ibm874", "cp874"},
{"ibm932", "cp932"},
{"ibm936", "cp936"},
{"ibm949", "cp949"},
{"ibm950", "cp950"},
{"iso-2022", "iso2022"},
{"iso-2022-jp", "iso2022-jp"},
{"iso-2022-kr", "iso2022-kr"},
{"iso-8859-1", "iso8859-1"},
{"iso-8859-10", "iso8859-10"},
{"iso-8859-13", "iso8859-13"},
{"iso-8859-14", "iso8859-14"},
{"iso-8859-15", "iso8859-15"},
{"iso-8859-16", "iso8859-16"},
{"iso-8859-2", "iso8859-2"},
{"iso-8859-3", "iso8859-3"},
{"iso-8859-4", "iso8859-4"},
{"iso-8859-5", "iso8859-5"},
{"iso-8859-6", "iso8859-6"},
{"iso-8859-7", "iso8859-7"},
{"iso-8859-8", "iso8859-8"},
{"iso-8859-9", "iso8859-9"},
{"iso2022", "iso2022"},
{"iso2022-jp", "iso2022-jp"},
{"iso2022-kr", "iso2022-kr"},
{"iso8859-1", "iso8859-1"},
{"iso8859-10", "iso8859-10"},
{"iso8859-13", "iso8859-13"},
{"iso8859-14", "iso8859-14"},
{"iso8859-15", "iso8859-15"},
{"iso8859-16", "iso8859-16"},
{"iso8859-2", "iso8859-2"},
{"iso8859-3", "iso8859-3"},
{"iso8859-4", "iso8859-4"},
{"iso8859-5", "iso8859-5"},
{"iso8859-6", "iso8859-6"},
{"iso8859-7", "iso8859-7"},
{"iso8859-8", "iso8859-8"},
{"iso8859-9", "iso8859-9"},
{"iso88591", "iso8859-1"},
{"iso885915", "iso8859-15"},
{"iso88592", "iso8859-2"},
{"iso88595", "iso8859-5"},
{"iso88596", "iso8859-6"},
{"iso88597", "iso8859-7"},
{"iso88598", "iso8859-8"},
{"iso88599", "iso8859-9"},
#ifdef hpux
{"ja", "shiftjis"},
#else
{"ja", "euc-jp"},
#endif
{"ja_jp", "euc-jp"},
{"ja_jp.euc", "euc-jp"},
{"ja_jp.eucjp", "euc-jp"},
{"ja_jp.jis", "iso2022-jp"},
{"ja_jp.mscode", "shiftjis"},
{"ja_jp.sjis", "shiftjis"},
{"ja_jp.ujis", "euc-jp"},
{"japan", "euc-jp"},
#ifdef hpux
{"japanese", "shiftjis"},
#else
{"japanese", "euc-jp"},
#endif
{"japanese-sjis", "shiftjis"},
{"japanese-ujis", "euc-jp"},
{"japanese.euc", "euc-jp"},
{"japanese.sjis", "shiftjis"},
{"jis0201", "jis0201"},
{"jis0208", "jis0208"},
{"jis0212", "jis0212"},
{"jp_jp", "shiftjis"},
{"ko", "euc-kr"},
{"ko_kr", "euc-kr"},
{"ko_kr.euc", "euc-kr"},
{"ko_kw.euckw", "euc-kr"},
{"koi8-r", "koi8-r"},
{"koi8-u", "koi8-u"},
{"korean", "euc-kr"},
{"ksc5601", "ksc5601"},
{"maccenteuro", "macCentEuro"},
{"maccroatian", "macCroatian"},
{"maccyrillic", "macCyrillic"},
{"macdingbats", "macDingbats"},
{"macgreek", "macGreek"},
{"maciceland", "macIceland"},
{"macjapan", "macJapan"},
{"macroman", "macRoman"},
{"macromania", "macRomania"},
{"macthai", "macThai"},
{"macturkish", "macTurkish"},
{"macukraine", "macUkraine"},
{"roman8", "iso8859-1"},
{"ru", "iso8859-5"},
{"ru_ru", "iso8859-5"},
{"ru_su", "iso8859-5"},
{"shiftjis", "shiftjis"},
{"sjis", "shiftjis"},
{"symbol", "symbol"},
{"tis-620", "tis-620"},
{"tis620", "tis-620"},
{"turkish8", "cp857"},
{"utf8", "utf-8"},
{"zh", "cp936"},
{"zh_cn.gb2312", "euc-cn"},
{"zh_cn.gbk", "euc-cn"},
{"zh_cz.gb2312", "euc-cn"},
{"zh_tw", "euc-tw"},
{"zh_tw.big5", "big5"},
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath(Tcl_Interp *interp,
int maxPathLen, char *tclLibPath);
#endif /* HAVE_COREFOUNDATION */
#if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
const char *str;
Tcl_DString buffer;
| | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
const char *str;
Tcl_DString buffer;
TclNewObj(pathPtr);
/*
* Look for the library relative to the TCL_LIBRARY env variable. If the
* last dirname in the TCL_LIBRARY path does not match the last dirname in
* the installLib variable, use the last dir name of installLib in
* addition to the orginal TCL_LIBRARY path.
*/
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = TclGetString(pathPtr);
*lengthPtr = pathPtr->length;
| | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = TclGetString(pathPtr);
*lengthPtr = pathPtr->length;
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, str, *lengthPtr + 1);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifdef __CYGWIN__
unameOK = 1;
if (!osInfoInitialized) {
| | | > | 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 |
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifdef __CYGWIN__
unameOK = 1;
if (!osInfoInitialized) {
void *handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getversion || getversion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sysInfo);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
* Side effects:
* Same as for Tcl_MacOSXOpenVersionedBundleResources.
*
*----------------------------------------------------------------------
*/
#ifdef HAVE_COREFOUNDATION
static int
MacOSXGetLibraryPath(
Tcl_Interp *interp,
int maxPathLen,
char *tclLibPath)
{
| > < < < | > | > > > > > | | > | 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 |
* Side effects:
* Same as for Tcl_MacOSXOpenVersionedBundleResources.
*
*----------------------------------------------------------------------
*/
#ifdef HAVE_COREFOUNDATION
#ifdef TCL_FRAMEWORK
static int
MacOSXGetLibraryPath(
Tcl_Interp *interp,
int maxPathLen,
char *tclLibPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp,
"com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen,
tclLibPath);
}
#else
static int
MacOSXGetLibraryPath(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int),
TCL_UNUSED(char *))
{
return TCL_ERROR;
}
#endif
#endif /* HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixNotfy.c.
1 2 3 4 5 6 | /* * tclUnixNotfy.c -- * * This file contains subroutines shared by all notifier backend * implementations on *nix platforms. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclUnixNotfy.c -- * * This file contains subroutines shared by all notifier backend * implementations on *nix platforms. * * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <poll.h> #include "tclInt.h" |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
| | | | 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 |
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
pthread_mutex_lock(¬ifierMutex);
tsdPtr->eventReady = 1;
# ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
# else
pthread_cond_broadcast(&tsdPtr->waitCV);
# endif /* __CYGWIN__ */
pthread_mutex_unlock(¬ifierMutex);
#endif /* TCL_THREADS */
#else /* !NOTIFIER_SELECT */
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",
(void *)tsdPtr);
}
|
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
1 2 3 4 5 6 | /* * tclUnixPipe.c -- * * This file implements the UNIX-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclUnixPipe.c -- * * This file implements the UNIX-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | * the children at close time. */ } PipeState; /* * Declarations for local functions defined in this file: */ | | | | | | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | * the children at close time. */ } PipeState; /* * Declarations for local functions defined in this file: */ static int PipeBlockModeProc(void *instanceData, int mode); static int PipeClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); static int PipeGetHandleProc(void *instanceData, int direction, void **handlePtr); static int PipeInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int PipeOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); static void PipeWatchProc(void *instanceData, int mask); static void RestoreSignals(void); static int SetupStdFile(TclFile file, int type); /* * This structure describes the channel type structure for command pipe based * I/O: */ |
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
*/
TclFile
TclpMakeFile(
Tcl_Channel channel, /* Channel to get file from. */
int direction) /* Either TCL_READABLE or TCL_WRITABLE. */
{
| | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
*/
TclFile
TclpMakeFile(
Tcl_Channel channel, /* Channel to get file from. */
int direction) /* Either TCL_READABLE or TCL_WRITABLE. */
{
void *data;
if (Tcl_GetChannelHandle(channel, direction, &data) != TCL_OK) {
return NULL;
}
return MakeFile(PTR2INT(data));
}
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
| | > | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileName(void)
{
Tcl_Obj *retVal, *nameObj;
int fd;
TclNewObj(nameObj);
Tcl_IncrRefCount(nameObj);
fd = TclUnixOpenTemporaryFile(NULL, NULL, NULL, nameObj);
if (fd == -1) {
Tcl_DecrRefCount(nameObj);
return NULL;
}
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
*
*----------------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
| | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
*
*----------------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
TCL_UNUSED(Tcl_Obj *) /*path*/)
{
Tcl_Obj *retval = TclpTempFileName();
if (retval == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create temporary file: %s",
Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 | * * Side effects: * A process is created. * *--------------------------------------------------------------------------- */ | < | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
*
* Side effects:
* A process is created.
*
*---------------------------------------------------------------------------
*/
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
int argc, /* Number of arguments in following array. */
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
| | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
dsArray = (Tcl_DString *)TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
#ifdef USE_VFORK
/*
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
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 channelId;
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
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 channelId;
PipeState *statePtr = (PipeState *)ckalloc(sizeof(PipeState));
int mode;
statePtr->inFile = readFile;
statePtr->outFile = writeFile;
statePtr->errorFile = errorFile;
statePtr->numPids = numPids;
statePtr->pidPtr = pidPtr;
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
| | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
int fileNums[2];
if (pipe(fileNums) < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
| | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewWideIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 | * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ | < | | | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
PipeBlockModeProc(
void *instanceData, /* Pipe state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (psPtr->inFile
&& TclUnixSetBlockingMode(GetFd(psPtr->inFile), mode) < 0) {
return errno;
}
if (psPtr->outFile
&& TclUnixSetBlockingMode(GetFd(psPtr->outFile), mode) < 0) {
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 | * Closes the command pipeline channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
* Closes the command pipeline channel.
*
*----------------------------------------------------------------------
*/
static int
PipeClose2Proc(
void *instanceData, /* The pipe to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
PipeState *pipePtr = (PipeState *)instanceData;
Tcl_Channel errChan;
int errorCode, result;
errorCode = 0;
result = 0;
if (((!flags) || (flags & TCL_CLOSE_READ)) && (pipePtr->inFile != NULL)) {
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeInputProc(
void *instanceData, /* Pipe 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. */
{
PipeState *psPtr = (PipeState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
* input device? */
*errorCodePtr = 0;
/*
* Assume there is always enough input available. This will block
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | | 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeOutputProc(
void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
PipeState *psPtr = (PipeState *)instanceData;
int written;
*errorCodePtr = 0;
/*
* Some OSes can throw an interrupt error, for which we should immediately
* retry. [Bug #415131]
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 | * seen by Tcl. * *---------------------------------------------------------------------- */ static void PipeWatchProc( | | | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
* seen by Tcl.
*
*----------------------------------------------------------------------
*/
static void
PipeWatchProc(
void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
PipeState *psPtr = (PipeState *)instanceData;
int newmask;
if (psPtr->inFile) {
newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
if (newmask) {
Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask,
(Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PipeGetHandleProc(
void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (direction == TCL_READABLE && psPtr->inFile) {
*handlePtr = INT2PTR(GetFd(psPtr->inFile));
return TCL_OK;
}
if (direction == TCL_WRITABLE && psPtr->outFile) {
*handlePtr = INT2PTR(GetFd(psPtr->outFile));
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PidObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 | return TCL_OK; } /* * Extract the process IDs from the pipe structure. */ | | | | 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
TclNewObj(resultPtr);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | #else typedef off_t Tcl_SeekOffset; # define TclOSseek lseek # define TclOSopen open #endif #ifdef __CYGWIN__ | | > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
#else
typedef off_t Tcl_SeekOffset;
# define TclOSseek lseek
# define TclOSopen open
#endif
#ifdef __CYGWIN__
#ifdef __cplusplus
extern "C" {
#endif
/* Make some symbols available without including <windows.h> */
# define DWORD unsigned int
# define CP_UTF8 65001
# define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004
# define HANDLE void *
# define HINSTANCE void *
# define SOCKET unsigned int
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
__declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
__declspec(dllimport) extern __stdcall int IsDebuggerPresent(void);
__declspec(dllimport) extern __stdcall int GetLastError(void);
__declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
__declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);
| < < < < < < > > > | | | | | 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 |
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
__declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
__declspec(dllimport) extern __stdcall int IsDebuggerPresent(void);
__declspec(dllimport) extern __stdcall int GetLastError(void);
__declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
__declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);
__declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
#ifdef __clang__
#pragma clang diagnostic pop
#endif
# define timezone _timezone
extern int TclOSstat(const char *name, void *statBuf);
extern int TclOSlstat(const char *name, void *statBuf);
#ifdef __cplusplus
}
#endif
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf)
# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf)
#else
# define TclOSstat(name, buf) stat(name, (struct stat *)buf)
# define TclOSlstat(name, buf) lstat(name, (struct stat *)buf)
#endif
/*
*---------------------------------------------------------------------------
* Miscellaneous includes that might be missing.
*---------------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | *--------------------------------------------------------------------------- * Supply definitions for macros to query wait status, if not already defined * in header files above. *--------------------------------------------------------------------------- */ #ifndef WIFEXITED | | | | | | | | 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 | *--------------------------------------------------------------------------- * Supply definitions for macros to query wait status, if not already defined * in header files above. *--------------------------------------------------------------------------- */ #ifndef WIFEXITED # define WIFEXITED(stat) (((*((int *) &(stat))) & 0xFF) == 0) #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ (((*((int *) &(stat)))) && ((*((int *) &(stat))) \ == ((*((int *) &(stat))) & 0x00FF))) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xFF) == 0177) #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* *--------------------------------------------------------------------------- * Define constants for waitpid() system call if they aren't defined by a * system header file. *--------------------------------------------------------------------------- |
| ︙ | ︙ |
Changes to unix/tclUnixSock.c.
1 2 3 4 5 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * * Copyright © 1995 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" |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
/*
* 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. */
struct addrinfo *addr; /* Iterator over addrlist. */
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 132 | #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ static int TcpConnect(Tcl_Interp *interp, TcpState *state); | > | | | | | | | | | > | | > > > > | | 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 |
#define SOCKET_BUFSIZE 4096
/*
* Static routines for this file:
*/
static void TcpAsyncCallback(void *clientData, int mask);
static int TcpConnect(Tcl_Interp *interp, TcpState *state);
static void TcpAccept(void *data, int mask);
static int TcpBlockModeProc(void *data, int mode);
static int TcpCloseProc(void *instanceData,
Tcl_Interp *interp);
static int TcpClose2Proc(void *instanceData,
Tcl_Interp *interp, int flags);
static int TcpGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int TcpGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int TcpInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int TcpOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
static void TcpThreadActionProc(void *instanceData, int action);
static void TcpWatchProc(void *instanceData, int mask);
static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static void WrapNotify(void *clientData, int mask);
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
#else
TCL_CLOSE2PROC, /* Close proc. */
#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
TcpClose2Proc, /* Close2 proc. */
TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
TcpThreadActionProc, /* thread action proc. */
NULL /* truncate proc. */
};
/*
* The following variable holds the network name of this host.
*/
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
const char *native = NULL;
#ifndef NO_UNAME
struct utsname u;
struct hostent *hp;
memset(&u, (int) 0, sizeof(struct utsname));
| | | | 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 |
const char *native = NULL;
#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 *)ckalloc(dot - u.nodename + 1);
memcpy(node, u.nodename, dot - u.nodename);
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
ckfree(node);
}
}
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
# if defined(SYS_NMLN) && (SYS_NMLEN >= 256)
char buffer[SYS_NMLEN];
# else
char buffer[256];
# endif
| | | | | 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 |
# if defined(SYS_NMLN) && (SYS_NMLEN >= 256)
char buffer[SYS_NMLEN];
# else
char buffer[256];
# endif
if (gethostname(buffer, sizeof(buffer)) >= 0) { /* INTL: Native. */
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
if (native) {
*lengthPtr = strlen(native);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, native, *lengthPtr + 1);
} else {
*lengthPtr = 0;
*valuePtr = (char *)ckalloc(1);
*valuePtr[0] = '\0';
}
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | * None. * * ---------------------------------------------------------------------- */ int TclpHasSockets( | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
* None.
*
* ----------------------------------------------------------------------
*/
int
TclpHasSockets(
TCL_UNUSED(Tcl_Interp *))
{
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 | * * Side effects: * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ | < | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
*
* Side effects:
* 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_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 | * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ | < | | | | 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 |
*
* Side effects:
* 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;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0);
if (bytesRead >= 0) {
return bytesRead;
}
if (errno == ECONNRESET) {
/*
* Turn ECONNRESET into a soft EOF condition.
*/
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | | | 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 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
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;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
if (written >= 0) {
return written;
}
*errorCodePtr = errno;
return -1;
}
/*
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 | * * Side effects: * Closes the socket of the channel. * *---------------------------------------------------------------------- */ | < | | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
*
* Side effects:
* Closes the socket of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
int errorCode = 0;
TcpFdList *fds;
/*
* Delete a file handler that may be active for this socket if this is a
* server socket - the file handler was created automatically by Tcl as
* part of the mechanism to accept new client connections. Channel
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | | | | 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 |
* Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *),
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, NULL);
}
if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->fds.fd, SHUT_RD) < 0)) {
readError = errno;
}
if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0)) {
writeError = errno;
}
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 | * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc( | | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
* 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;
size_t len = 0;
WaitForConnect(statePtr, NULL);
if (optionName != NULL) {
len = strlen(optionName);
}
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
*
* Results:
* None.
*
* Side effects:
* Sets up the notifier so that a future event on the channel will be
* seen by Tcl.
*
* ----------------------------------------------------------------------
*/
static void
WrapNotify(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Handles detach/attach for asynchronously connecting socket.
*
* Reassigning the file handler associated with thread-related channel
* notification, responsible for callbacks (signaling that asynchronous
* connection attempt has succeeded or failed).
*
* Results:
* None.
*
* ----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
void *instanceData,
int action)
{
TcpState *statePtr = (TcpState *)instanceData;
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* Async-connecting socket must get reassigned handler if it have been
* transferred to another thread. Remove the handler if the socket is
* not managed by this thread anymore and create new handler (TSD related)
* so the callback will run in the correct thread, bug [f583715154].
*/
switch (action) {
case TCL_CHANNEL_THREAD_REMOVE:
CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
Tcl_DeleteFileHandler(statePtr->fds.fd);
break;
case TCL_CHANNEL_THREAD_INSERT:
Tcl_CreateFileHandler(statePtr->fds.fd,
TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr);
SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
break;
}
}
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
*
* Results:
* None.
*
* Side effects:
* Sets up the notifier so that a future event on the channel will be
* seen by Tcl.
*
* ----------------------------------------------------------------------
*/
static void
WrapNotify(
void *clientData,
int mask)
{
TcpState *statePtr = (TcpState *) clientData;
int newmask = mask & statePtr->interest;
if (newmask == 0) {
/*
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
static void
TcpWatchProc(
| | | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
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;
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).
*/
|
| ︙ | ︙ | |||
1094 1095 1096 1097 1098 1099 1100 | * * Side effects: * None. * * ---------------------------------------------------------------------- */ | < | | | | | < < | | | 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 |
*
* Side effects:
* 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->fds.fd);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpAsyncCallback --
*
* Called by the event handler that TcpConnect sets up internally for
* [socket -async] to get notified when the asynchronous connection
* attempt has succeeded or failed.
*
* ----------------------------------------------------------------------
*/
static void
TcpAsyncCallback(
void *clientData, /* The socket state. */
TCL_UNUSED(int) /*mask*/)
{
TcpConnect(NULL, (TcpState *)clientData);
}
/*
* ----------------------------------------------------------------------
*
* TcpConnect --
*
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
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);
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) {
| > < | 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 |
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
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) {
|
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
| | | 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)ckalloc(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;
|
| ︙ | ︙ | |||
1432 1433 1434 1435 1436 1437 1438 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( | | | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
TCL_READABLE | TCL_WRITABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
| | | 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
|
| ︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 |
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. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
| | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
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. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
int status = 0, sock = -1, optvalue, port, chosenport;
struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */
TcpState *statePtr = NULL;
char channelName[SOCK_CHAN_LENGTH];
const char *errorMsg = NULL;
TcpFdList *fds = NULL, *newfds;
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
| | | | 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
newfds->statePtr = statePtr;
fds = newfds;
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 | * Side effects: * Creates a new connection socket. Calls the registered callback for the * connection acceptance mechanism. * *---------------------------------------------------------------------- */ | < | | | | | 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 |
* Side effects:
* Creates a new connection socket. Calls the registered callback for the
* connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
void *data, /* Callback token. */
TCL_UNUSED(int) /*mask*/)
{
TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
newsock = accept(fds->fd, &addr.sa, &len);
if (newsock < 0) {
return;
}
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = (TcpState *)ckalloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, TCL_READABLE | TCL_WRITABLE);
|
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
1 2 3 4 5 | /* * tclUnixTest.c -- * * Contains platform specific test commands for the Unix platform. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclUnixTest.c -- * * Contains platform specific test commands for the Unix platform. * * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | * None. * *---------------------------------------------------------------------- */ static int TestfilehandlerCmd( | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilehandlerCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
static int initialized = 0;
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
static void
TestFileHandlerProc(
ClientData clientData, /* Points to a Pipe structure. */
int mask) /* Indicates which events happened:
* TCL_READABLE or TCL_WRITABLE. */
{
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
static void
TestFileHandlerProc(
ClientData clientData, /* Points to a Pipe structure. */
int mask) /* Indicates which events happened:
* TCL_READABLE or TCL_WRITABLE. */
{
Pipe *pipePtr = (Pipe *)clientData;
if (mask & TCL_READABLE) {
pipePtr->readCount++;
}
if (mask & TCL_WRITABLE) {
pipePtr->writeCount++;
}
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 | * None. * *---------------------------------------------------------------------- */ static int TestfilewaitCmd( | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilewaitCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 | * None. * *---------------------------------------------------------------------- */ static int TestfindexecutableCmd( | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfindexecutableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Obj *saveName;
if (objc != 2) {
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | * None. * *---------------------------------------------------------------------- */ static int TestforkCmd( | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestforkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 | * Sets up an signal and async handlers. * *---------------------------------------------------------------------- */ static int TestalarmCmd( | | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
* Sets up an signal and async handlers.
*
*----------------------------------------------------------------------
*/
static int
TestalarmCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec = 1;
struct sigaction action;
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
(void) alarm(sec);
return TCL_OK;
#else
Tcl_AppendResult(interp,
"warning: sigaction SA_RESTART not support on this platform",
NULL);
return TCL_ERROR;
#endif
}
| > | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 |
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
(void) alarm(sec);
return TCL_OK;
#else
Tcl_AppendResult(interp,
"warning: sigaction SA_RESTART not support on this platform",
NULL);
return TCL_ERROR;
#endif
}
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 | * Calls the Tcl Async handler. * *---------------------------------------------------------------------- */ static void AlarmHandler( | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
* Calls the Tcl Async handler.
*
*----------------------------------------------------------------------
*/
static void
AlarmHandler(
TCL_UNUSED(int) /*signum*/)
{
gotsig = "1";
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 | * Resets the value of gotsig back to '0'. * *---------------------------------------------------------------------- */ static int TestgotsigCmd( | | | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
* Resets the value of gotsig back to '0'.
*
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *))
{
Tcl_AppendResult(interp, gotsig, NULL);
gotsig = "0";
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 | * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int i, mode;
if (objc < 2) {
|
| ︙ | ︙ |
Changes to unix/tclUnixThrd.c.
1 2 3 4 5 | /* * tclUnixThrd.c -- * * This file implements the UNIX-specific thread support. * | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclUnixThrd.c -- * * This file implements the UNIX-specific thread support. * * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_NO_DEPRECATED */
/*
| | | | | | 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 |
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_NO_DEPRECATED */
/*
* globalLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
*/
static pthread_mutex_t globalLock = PTHREAD_MUTEX_INITIALIZER;
/*
* initLock is used to serialize initialization and finalization of Tcl. It
* cannot use any dynamically allocated storage.
*/
static pthread_mutex_t initLock = PTHREAD_MUTEX_INITIALIZER;
/*
* allocLock is used by Tcl's version of malloc for synchronization. For
* obvious reasons, cannot use any dynamically allocated storage.
*/
static PMutex allocLock;
static pthread_once_t allocLockInitOnce = PTHREAD_ONCE_INIT;
static void
allocLockInit(void)
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
int result;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
if (stackSize != TCL_THREAD_STACK_DEFAULT) {
| | | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
int result;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
if (stackSize != TCL_THREAD_STACK_DEFAULT) {
pthread_attr_setstacksize(&attr, stackSize);
#ifdef TCL_THREAD_STACK_MIN
} else {
/*
* Certain systems define a thread stack size that by default is too
* small for many operations. The user has the option of defining
* TCL_THREAD_STACK_MIN to a value large enough to work for their
* needs. This would look like (for 128K min stack):
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
| | | | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
(void * (*)(void *))(void *)proc, (void *)clientData) &&
pthread_create(&theThread, NULL,
(void * (*)(void *))(void *)proc, (void *)clientData)) {
result = TCL_ERROR;
} else {
*idPtr = (Tcl_ThreadId)theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 |
void
TclFinalizeLock(void)
{
#if TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
| | | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 |
void
TclFinalizeLock(void)
{
#if TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need any
* destruction: globalLock, allocLock, and initLock.
*/
pthread_mutex_unlock(&initLock);
#endif
}
/*
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | 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 |
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalLock
*
* This procedure is used to grab a lock that serializes creation and
* finalization of serialization objects. This interface is only needed
* in finalization; it is hidden during creation of the objects.
*
* This lock must be different than the initLock because the initLock is
* held during creation of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Acquire the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalLock(void)
{
#if TCL_THREADS
pthread_mutex_lock(&globalLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalUnlock
*
* This procedure is used to release a lock that serializes creation and
* finalization of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Release the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalUnlock(void)
{
#if TCL_THREADS
pthread_mutex_unlock(&globalLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* 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:
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
| | | | | | 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 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* Really (PMutex **) */
{
PMutex *pmutexPtr;
if (*mutexPtr == NULL) {
pthread_mutex_lock(&globalLock);
if (*mutexPtr == NULL) {
/*
* Double inside global lock check to avoid a race condition.
*/
pmutexPtr = (PMutex *)ckalloc(sizeof(PMutex));
PMutexInit(pmutexPtr);
*mutexPtr = (Tcl_Mutex) pmutexPtr;
TclRememberMutex(mutexPtr);
}
pthread_mutex_unlock(&globalLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
PMutexLock(pmutexPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 | *---------------------------------------------------------------------- * * TclpFinalizeMutex -- * * This procedure is invoked to clean up one mutex. This is only safe to * call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The mutex list is deallocated. * |
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
| | | | | | | 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 |
const Tcl_Time *timePtr) /* Timeout on waiting period */
{
pthread_cond_t *pcondPtr;
PMutex *pmutexPtr;
struct timespec ptime;
if (*condPtr == NULL) {
pthread_mutex_lock(&globalLock);
/*
* Double check inside mutex to avoid race, then initialize condition
* variable if necessary.
*/
if (*condPtr == NULL) {
pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t));
pthread_cond_init(pcondPtr, NULL);
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
pthread_mutex_unlock(&globalLock);
}
pmutexPtr = *((PMutex **)mutexPtr);
pcondPtr = *((pthread_cond_t **)condPtr);
if (timePtr == NULL) {
PCondWait(pcondPtr, pmutexPtr);
} else {
Tcl_Time now;
/*
* Make sure to take into account the microsecond component of the
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
| | | | | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_ConditionNotify(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *((pthread_cond_t **)condPtr);
if (pcondPtr != NULL) {
pthread_cond_broadcast(pcondPtr);
} else {
/*
* No-one has used the condition variable, so there are no waiters.
*/
}
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeCondition --
*
* This procedure is invoked to clean up a condition variable. This is
* only safe to call at the end of time.
*
* This assumes the Global Lock is held.
*
* Results:
* None.
*
* Side effects:
* The condition variable is deallocated.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
ckfree(pcondPtr);
*condPtr = NULL;
}
}
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
Tcl_Mutex *
TclpNewAllocMutex(void)
{
AllocMutex *lockPtr;
PMutex *plockPtr;
| | | | 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 |
Tcl_Mutex *
TclpNewAllocMutex(void)
{
AllocMutex *lockPtr;
PMutex *plockPtr;
lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
plockPtr = &lockPtr->plock;
lockPtr->tlock = (Tcl_Mutex) plockPtr;
PMutexInit(&lockPtr->plock);
return &lockPtr->tlock;
}
void
TclpFreeAllocMutex(
Tcl_Mutex *mutex) /* The alloc mutex to free. */
{
AllocMutex *lockPtr = (AllocMutex *)mutex;
if (!lockPtr) {
return;
}
PMutexDestroy(&lockPtr->plock);
free(lockPtr);
}
|
| ︙ | ︙ | |||
913 914 915 916 917 918 919 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
| | | | | | | | | 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 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0);
if (NULL == ptkeyPtr) {
Tcl_Panic("unable to allocate thread key!");
}
if (pthread_key_create(ptkeyPtr, NULL)) {
Tcl_Panic("unable to create pthread key!");
}
return ptkeyPtr;
}
void
TclpThreadDeleteKey(
void *keyPtr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)keyPtr;
if (pthread_key_delete(*ptkeyPtr)) {
Tcl_Panic("unable to delete key!");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetGlobalTSD(
void *tsdKeyPtr,
void *ptr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
if (pthread_setspecific(*ptkeyPtr, ptr)) {
Tcl_Panic("unable to set global TSD value");
}
}
void *
TclpThreadGetGlobalTSD(
void *tsdKeyPtr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
return pthread_getspecific(*ptkeyPtr);
}
#endif /* TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixTime.c.
1 2 3 4 5 6 | /* * tclUnixTime.c -- * * Contains Unix specific versions of Tcl functions that obtain time * values from the operating system. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclUnixTime.c -- * * Contains Unix specific versions of Tcl functions that obtain time * values from the operating system. * * Copyright © 1995 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" #if defined(TCL_WIDE_CLICKS) && defined(MAC_OSX_TCL) |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. */ Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. */ Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; void *tclTimeClientData = NULL; /* *---------------------------------------------------------------------- * * TclpGetSeconds -- * * This procedure returns the number of seconds from the epoch. On most |
| ︙ | ︙ | |||
504 505 506 507 508 509 510 | * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime( | | | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
* See above.
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
TCL_UNUSED(ClientData))
{
/* Native scale is 1:1. Nothing is done */
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
| | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
TCL_UNUSED(ClientData))
{
struct timeval tv;
(void) gettimeofday(&tv, NULL);
timePtr->sec = tv.tv_sec;
timePtr->usec = tv.tv_usec;
}
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
if (lastTZ == NULL || strcmp(lastTZ, newTZ)) {
tzset();
if (lastTZ == NULL) {
Tcl_CreateExitHandler(CleanupMemory, NULL);
} else {
ckfree(lastTZ);
}
| | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
if (lastTZ == NULL || strcmp(lastTZ, newTZ)) {
tzset();
if (lastTZ == NULL) {
Tcl_CreateExitHandler(CleanupMemory, NULL);
} else {
ckfree(lastTZ);
}
lastTZ = (char *)ckalloc(strlen(newTZ) + 1);
strcpy(lastTZ, newTZ);
}
Tcl_MutexUnlock(&tmMutex);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 | * Frees allocated memory. * *---------------------------------------------------------------------- */ static void CleanupMemory( | | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
* Frees allocated memory.
*
*----------------------------------------------------------------------
*/
static void
CleanupMemory(
TCL_UNUSED(ClientData))
{
ckfree(lastTZ);
}
#endif /* TCL_NO_DEPRECATED */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclXtNotify.c.
1 2 3 4 5 6 | /* * tclXtNotify.c -- * * This file contains the notifier driver implementation for the Xt * intrinsics. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclXtNotify.c -- * * This file contains the notifier driver implementation for the Xt * intrinsics. * * Copyright © 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. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | * Destroys the notifier window. * *---------------------------------------------------------------------- */ static void NotifierExitHandler( | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
* Destroys the notifier window.
*
*----------------------------------------------------------------------
*/
static void
NotifierExitHandler(
TCL_UNUSED(ClientData))
{
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
}
for (; notifier.firstFileHandlerPtr != NULL; ) {
Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
}
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | * Processes all queued events. * *---------------------------------------------------------------------- */ static void TimerProc( | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
* Processes all queued events.
*
*----------------------------------------------------------------------
*/
static void
TimerProc(
TCL_UNUSED(XtPointer),
XtIntervalId *id)
{
if (*id != notifier.currentTimeout) {
return;
}
notifier.currentTimeout = 0;
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->read = 0;
filePtr->write = 0;
filePtr->except = 0;
filePtr->readyMask = 0;
filePtr->mask = 0;
filePtr->nextPtr = notifier.firstFileHandlerPtr;
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
/*
* Process events on the Tcl event queue before returning to Xt.
*/
|
| ︙ | ︙ |
Changes to unix/tclXtTest.c.
1 2 3 4 5 | /* * tclXtTest.c -- * * Contains commands for Xt notifier specific tests on Unix. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclXtTest.c -- * * Contains commands for Xt notifier specific tests on Unix. * * Copyright © 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. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | * None. * *---------------------------------------------------------------------- */ static int TesteventloopCmd( | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
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 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann | > > > < < < | | 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 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # 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@ -D_ATL_XP_TARGETING=1 -D__USE_MINGW_ANSI_STDIO=0 -DMP_FIXED_CUTOFFS -DMP_NO_STDINT # 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 |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 120 121 122 123 124 125 126 | 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)') 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)') # Fully qualify library path so that `make test` # does not depend on the current directory. | > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | 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)') 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)') # Fully qualify library path so that `make test` # does not depend on the current directory. |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
TCL_VFS_ROOT = libtcl.vfs
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
| | | | | | | | < | 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 |
TCL_VFS_ROOT = libtcl.vfs
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX}
REG_DLL_FILE = 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.3 [list load [file normalize ${DDE_DLL_FILE}]];\
package ifneeded registry 1.3.5 [list load [file normalize ${REG_DLL_FILE}]]
TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${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
# available *BEFORE* running make for the first time. Certain build targets
# (make genstubs, make install) need it to be available on the PATH. This
# executable should *NOT* be required just to do a normal build although
# it can be required to run make dist.
TCL_EXE = @TCL_EXE@
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
| | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -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}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
$(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \
(for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \
mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \
$(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \
done) && \
$(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \
$(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \
| | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
$(LN) $$(find $(TOP_DIR)/library/* -maxdepth 0 -type f) ${TCL_VFS_PATH}/ && \
(for D in $$(find $(TOP_DIR)/library/* -maxdepth 0 -type d); do \
mkdir -p "${TCL_VFS_PATH}/$$(basename $$D)"; \
$(LN) -s $$D/* ${TCL_VFS_PATH}/$$(basename $$D)/; \
done) && \
$(LN) ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl && \
$(LN) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde/ && \
$(LN) ${REG_DLL_FILE} ${TCL_VFS_PATH}/registry/ \
) || ( \
$(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
$(COPY) -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
$(COPY) ${DDE_DLL_FILE} ${TCL_VFS_PATH}/dde; \
$(COPY) ${REG_DLL_FILE} ${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 ..)
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 | $(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 | | | | | | 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 |
$(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_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}; \
${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
${TCL_LIB_FILE}: ${TCL_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@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)
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
| | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
-DCFG_RUNTIME_PATH="\"$(bindir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
$(ZLIB_INCLUDE) -I$(MINIZIP_DIR_NATIVE) @DEPARG@ $(CC_OBJNAME)
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
tclPkgConfig.${OBJEXT}: tclPkgConfig.c
$(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \
| | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
tclPkgConfig.${OBJEXT}: tclPkgConfig.c
$(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR_NATIVE)\"" \
\
-DCFG_RUNTIME_LIBDIR="\"$(libdir_native)\"" \
-DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 | $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \ do \ | | | | | | | | | | | | | | | | | | > > > > > > > > | | | | | | | | | | | | | | | | | 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 |
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
chmod 755 "$$i"; \
else true; \
fi; \
done;
@for i in dde${DDEDOTVER} registry${REGDOTVER}; \
do \
if [ ! -d "$(LIB_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(LIB_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
$(COPY) $$i "$(BIN_INSTALL_DIR)"; \
fi; \
done
@for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \
$(COPY) $$i "$(LIB_INSTALL_DIR)"; \
fi; \
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo Installing $(DDE_LIB_FILE); \
$(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
$(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
install-libraries-zipfs-shared: libraries
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries install-tzdata install-msgs
@for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \
"$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
else true; \
fi; \
done;
@for i in opt0.4 cookiejar0.2 encoding; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(MODULE_INSTALL_DIR)/$$i"; \
else true; \
fi; \
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,txt.gz}; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
@echo "Installing package http 2.10.0a1 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10.0a1.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)/8.7/msgcat-1.7.1.tm";
@echo "Installing package tcltest 2.5.3 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm";
@echo "Installing package platform 1.0.15 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.15.tm";
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm";
@echo "Installing encodings";
@for i in $(ROOT_DIR)/library/encoding/*.enc; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
done;
install-tzdata:
@echo "Installing time zone data"
@$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR_NATIVE)/tzdata"
install-msgs:
@echo "Installing message catalogs"
$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR_NATIVE)/msgs"
install-doc: doc
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 | depend: Makefile: $(SRC_DIR)/Makefile.in ./config.status cleanhelp: | | | | 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 |
depend:
Makefile: $(SRC_DIR)/Makefile.in
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
$(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh
$(RM) *.pch *.ilk *.pdb
$(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
$(RM) *.zip
$(RMDIR) *.vfs
distclean: distclean-packages clean
$(RM) Makefile config.status config.cache config.log tclConfig.sh \
config.status.lineno tclsh.exe.manifest
#
# Bundled package targets
#
PKG_CFG_ARGS = @PKG_CFG_ARGS@
PKG_DIR = ./pkgs
|
| ︙ | ︙ |
Changes to win/buildall.vc.bat.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. :: | | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | set OPTS=none if not %SYMBOLS%.==. set OPTS=symbols nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. :: set OPTS=static if not %SYMBOLS%.==. set OPTS=symbols,static nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 if errorlevel 1 goto error set OPTS= set SYMBOLS= goto end |
| ︙ | ︙ |
Changes to win/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | | > | > | > > > > > > > > < < < < < < < < | | < | | < < < < < < | < < < < < < < | > > | < < > | | > > > > > > > > > | > > > > | < < < < < < < > | > > > | | < < < < < < < < < < < < < < < < < < < < | 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 |
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.70 for tcl 8.7.
#
#
# Copyright (C) 1992-1996, 1998-2017, 2020 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## -------------------- ##
## M4sh Initialization. ##
## -------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
as_nop=:
if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else $as_nop
case `(set -o) 2>/dev/null` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
# Reset variables that may have inherited troublesome values from
# the environment.
# IFS needs to be set, to space, tab, and newline, in precisely that order.
# (If _AS_PATH_WALK were called with IFS unset, it would have the
# side effect of setting IFS to empty, thus disabling word splitting.)
# Quoting is to prevent editors from complaining about space-tab.
as_nl='
'
export as_nl
IFS=" "" $as_nl"
PS1='$ '
PS2='> '
PS4='+ '
# Ensure predictable behavior from utilities with locale-dependent output.
LC_ALL=C
export LC_ALL
LANGUAGE=C
export LANGUAGE
# We cannot yet rely on "unset" to work, but we need these variables
# to be unset--not just set to an empty or harmless value--now, to
# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
# also avoids known problems related to "unset" and subshell syntax
# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
do eval test \${$as_var+y} \
&& ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
done
# Ensure that fds 0, 1, and 2 are open.
if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
# The user is always right.
if ${PATH_SEPARATOR+false} :; then
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
(PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
PATH_SEPARATOR=';'
}
fi
# Find who we are. Look in the path if we contain no directory separator.
as_myself=
case $0 in #((
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
test -r "$as_dir$0" && as_myself=$as_dir$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
exit 1
fi
# Use a proper internal environment variable to ensure we don't fall
# into an infinite loop, continuously re-executing ourselves.
if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
_as_can_reexec=no; export _as_can_reexec;
# We cannot yet assume a decent shell, so we have to provide a
# neutralization value for shells without unset; and this also
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
| | | | > > | | > | > > | > | | > | > | > > > | | > | > > > > > > | | > | < > | > | | > | | | | | | | 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 |
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
exit 255
fi
# We don't want this to propagate to other subprocesses.
{ _as_can_reexec=; unset _as_can_reexec;}
if test "x$CONFIG_SHELL" = x; then
as_bourne_compatible="as_nop=:
if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
# is contrary to our usage. Disable this feature.
alias -g '\${1+\"\$@\"}'='\"\$@\"'
setopt NO_GLOB_SUBST
else \$as_nop
case \`(set -o) 2>/dev/null\` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
"
as_required="as_fn_return () { (exit \$1); }
as_fn_success () { as_fn_return 0; }
as_fn_failure () { as_fn_return 1; }
as_fn_ret_success () { return 0; }
as_fn_ret_failure () { return 1; }
exitcode=0
as_fn_success || { exitcode=1; echo as_fn_success failed.; }
as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
if ( set x; as_fn_ret_success y && test x = \"\$1\" )
then :
else \$as_nop
exitcode=1; echo positional parameters were not saved.
fi
test x\$exitcode = x0 || exit 1
blah=\$(echo \$(echo blah))
test x\"\$blah\" = xblah || exit 1
test -x / || exit 1"
as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
test \$(( 1 + 1 )) = 2 || exit 1"
if (eval "$as_required") 2>/dev/null
then :
as_have_required=yes
else $as_nop
as_have_required=no
fi
if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null
then :
else $as_nop
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
as_found=false
for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
as_found=:
case $as_dir in #(
/*)
for as_base in sh bash ksh sh5; do
# Try only shells that exist, to save several forks.
as_shell=$as_dir$as_base
if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null
then :
CONFIG_SHELL=$as_shell as_have_required=yes
if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null
then :
break 2
fi
fi
done;;
esac
as_found=false
done
IFS=$as_save_IFS
if $as_found
then :
else $as_nop
if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null
then :
CONFIG_SHELL=$SHELL as_have_required=yes
fi
fi
if test "x$CONFIG_SHELL" != x
then :
export CONFIG_SHELL
# We cannot yet assume a decent shell, so we have to provide a
# neutralization value for shells without unset; and this also
# works around shells that cannot unset nonexistent variables.
# Preserve -v and -x to the replacement shell.
BASH_ENV=/dev/null
ENV=/dev/null
(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
case $- in # ((((
*v*x* | *x*v* ) as_opts=-vx ;;
*v* ) as_opts=-v ;;
*x* ) as_opts=-x ;;
* ) as_opts= ;;
esac
exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
# Admittedly, this is quite paranoid, since all the known shells bail
# out after a failed `exec'.
printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
exit 255
fi
if test x$as_have_required = xno
then :
printf "%s\n" "$0: This script requires a shell more modern than all"
printf "%s\n" "$0: the shells that I found on your system."
if test ${ZSH_VERSION+y} ; then
printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"
printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."
else
printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system,
$0: including any error possibly output before this
$0: message. Then install a modern shell, or manually run
$0: the script under such a shell if you do have one."
fi
exit 1
fi
fi
|
| ︙ | ︙ | |||
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 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
return $1
} # as_fn_set_status
# as_fn_exit STATUS
# -----------------
# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
as_fn_exit ()
{
set +e
as_fn_set_status $1
exit $1
} # as_fn_exit
# as_fn_mkdir_p
# -------------
# Create "$as_dir" as a directory, including parents if necessary.
as_fn_mkdir_p ()
{
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
| > > > > > > > > > | | | 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 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
return $1
} # as_fn_set_status
# as_fn_exit STATUS
# -----------------
# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
as_fn_exit ()
{
set +e
as_fn_set_status $1
exit $1
} # as_fn_exit
# as_fn_nop
# ---------
# Do nothing but, unlike ":", preserve the value of $?.
as_fn_nop ()
{
return $?
}
as_nop=as_fn_nop
# as_fn_mkdir_p
# -------------
# Create "$as_dir" as a directory, including parents if necessary.
as_fn_mkdir_p ()
{
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. | | > | | > | > > > > > > > > | | | 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 |
} # as_fn_executable_p
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
then :
eval 'as_fn_append ()
{
eval $1+=\$2
}'
else $as_nop
as_fn_append ()
{
eval $1=\$$1\$2
}
fi # as_fn_append
# as_fn_arith ARG...
# ------------------
# Perform arithmetic evaluation on the ARGs, and store the result in the
# global $as_val. Take advantage of shells that can avoid forks. The arguments
# must be portable across $(()) and expr.
if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
then :
eval 'as_fn_arith ()
{
as_val=$(( $* ))
}'
else $as_nop
as_fn_arith ()
{
as_val=`expr "$@" || test $? -eq 1`
}
fi # as_fn_arith
# as_fn_nop
# ---------
# Do nothing but, unlike ":", preserve the value of $?.
as_fn_nop ()
{
return $?
}
as_nop=as_fn_nop
# as_fn_error STATUS ERROR [LINENO LOG_FD]
# ----------------------------------------
# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
# script with STATUS, using 1 if that was 0.
as_fn_error ()
{
as_status=$1; test $as_status -eq 0 && as_status=1
if test "$4"; then
as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
printf "%s\n" "$as_me: error: $2" >&2
as_fn_exit $as_status
} # as_fn_error
if expr a : '\(a\)' >/dev/null 2>&1 &&
test "X`expr 00001 : '.*\(...\)'`" = X001; then
as_expr=expr
else
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || | | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
as_dirname=false
fi
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
| | > > > > > > > > > > > | 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 |
N
:loop
s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
t loop
s/-\n.*//
' >$as_me.lineno &&
chmod +x "$as_me.lineno" ||
{ printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
# If we had to re-execute with $CONFIG_SHELL, we're ensured to have
# already done that, so ensure we don't try to do so again and fall
# in an infinite loop. This has already happened in practice.
_as_can_reexec=no; export _as_can_reexec
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
. "./$as_me.lineno"
# Exit status is that of the last command.
exit
}
# Determine whether it's possible to make 'echo' print without a newline.
# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
# for compatibility with existing Makefiles.
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
# For backward compatibility with old third-party macros, we provide
# the shell variables $as_echo and $as_echo_n. New code should use
# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
as_echo='printf %s\n'
as_echo_n='printf %s'
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 | LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. | | | | | | | | | | | < < < < < < < < < < < < < < > > > > > > > > > > | 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 | LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' PACKAGE_VERSION='8.7' PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' ac_unique_file="../generic/tcl.h" # Factoring default headers for most tests. ac_includes_default="\ #include <stddef.h> #ifdef HAVE_STDIO_H # include <stdio.h> #endif #ifdef HAVE_STDLIB_H # include <stdlib.h> #endif #ifdef HAVE_STRING_H # include <string.h> #endif #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #ifdef HAVE_STDINT_H # include <stdint.h> #endif #ifdef HAVE_STRINGS_H # include <strings.h> #endif #ifdef HAVE_SYS_TYPES_H # include <sys/types.h> #endif #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #endif #ifdef HAVE_UNISTD_H # include <unistd.h> #endif" ac_header_c_list= ac_subst_vars='LTLIBOBJS LIBOBJS RES RC_DEFINES RC_DEFINE RC_INCLUDE RC_TYPE |
| ︙ | ︙ | |||
665 666 667 668 669 670 671 | CC_EXENAME CC_OBJNAME DEPARG EXTRA_CFLAGS CFG_TCL_EXPORT_FILE_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_SHARED_LIB_SUFFIX | < | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 | CC_EXENAME CC_OBJNAME DEPARG EXTRA_CFLAGS CFG_TCL_EXPORT_FILE_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_SHARED_LIB_SUFFIX TCL_BIN_DIR TCL_SRC_DIR TCL_DLL_FILE TCL_BUILD_STUB_LIB_PATH TCL_BUILD_STUB_LIB_SPEC TCL_INCLUDE_SPEC TCL_STUB_LIB_PATH |
| ︙ | ︙ | |||
693 694 695 696 697 698 699 700 701 702 703 704 705 706 | TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION MACHINE TCL_WIN_VERSION VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_MSGS INSTALL_LIBRARIES TCL_ZIP_FILE ZIPFS_BUILD ZIP_INSTALL_OBJS | > > > | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | TCL_MINOR_VERSION TCL_MAJOR_VERSION TCL_VERSION MACHINE TCL_WIN_VERSION VC_MANIFEST_EMBED_EXE VC_MANIFEST_EMBED_DLL EGREP GREP CPP LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_MSGS INSTALL_LIBRARIES TCL_ZIP_FILE ZIPFS_BUILD ZIP_INSTALL_OBJS |
| ︙ | ︙ | |||
723 724 725 726 727 728 729 | WINE CYGPATH SHARED_BUILD SET_MAKE RC RANLIB AR | < < < | 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | WINE CYGPATH SHARED_BUILD SET_MAKE RC RANLIB AR OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC |
| ︙ | ︙ | |||
752 753 754 755 756 757 758 759 760 761 762 763 764 765 | pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir | > | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir |
| ︙ | ︙ | |||
830 831 832 833 834 835 836 837 838 |
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
includedir='${prefix}/include'
oldincludedir='/usr/include'
| > | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 |
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datarootdir='${prefix}/share'
datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
infodir='${datarootdir}/info'
htmldir='${docdir}'
dvidir='${docdir}'
pdfdir='${docdir}'
psdir='${docdir}'
libdir='${exec_prefix}/lib'
localedir='${datarootdir}/locale'
|
| ︙ | ︙ | |||
859 860 861 862 863 864 865 | case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac | < < | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
case $ac_option in
*=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
*=) ac_optarg= ;;
*) ac_optarg=yes ;;
esac
case $ac_dashdash$ac_option in
--)
ac_dashdash=yes ;;
-bindir | --bindir | --bindi | --bind | --bin | --bi)
ac_prev=bindir ;;
-bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
| --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
datarootdir=$ac_optarg ;;
-disable-* | --disable-*)
ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
| --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
datarootdir=$ac_optarg ;;
-disable-* | --disable-*)
ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid feature name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"enable_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
927 928 929 930 931 932 933 |
-dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
dvidir=$ac_optarg ;;
-enable-* | --enable-*)
ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
-dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
dvidir=$ac_optarg ;;
-enable-* | --enable-*)
ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid feature name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"enable_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
ac_prev=psdir ;;
-psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
psdir=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir=$ac_optarg ;;
| > > > > > > > > > | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 |
ac_prev=psdir ;;
-psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
psdir=$ac_optarg ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-runstatedir | --runstatedir | --runstatedi | --runstated \
| --runstate | --runstat | --runsta | --runst | --runs \
| --run | --ru | --r)
ac_prev=runstatedir ;;
-runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
| --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
| --run=* | --ru=* | --r=*)
runstatedir=$ac_optarg ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
| --sbi=* | --sb=*)
sbindir=$ac_optarg ;;
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
| | | | | | 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 |
-version | --version | --versio | --versi | --vers | -V)
ac_init_version=: ;;
-with-* | --with-*)
ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid package name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"with_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
eval with_$ac_useropt=\$ac_optarg ;;
-without-* | --without-*)
ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`
# Reject names that are not valid shell variable names.
expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
as_fn_error $? "invalid package name: \`$ac_useropt'"
ac_useropt_orig=$ac_useropt
ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
case $ac_user_opts in
*"
"with_$ac_useropt"
"*) ;;
*) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
ac_unrecognized_sep=', ';;
esac
|
| ︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 |
as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
esac
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
| | | | | | 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 |
as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;
esac
eval $ac_envvar=\$ac_optarg
export $ac_envvar ;;
*)
# FIXME: should be removed in autoconf 3.0.
printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2
expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2
: "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
;;
esac
done
if test -n "$ac_prev"; then
ac_option=--`echo $ac_prev | sed 's/_/-/g'`
as_fn_error $? "missing argument to $ac_option"
fi
if test -n "$ac_unrecognized_opts"; then
case $enable_option_checking in
no) ;;
fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
*) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
esac
fi
# Check all directory arguments for consistency.
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
datadir sysconfdir sharedstatedir localstatedir includedir \
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
libdir localedir mandir runstatedir
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
case $ac_val in
*/ )
ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
eval $ac_var=\$ac_val;;
|
| ︙ | ︙ | |||
1275 1276 1277 1278 1279 1280 1281 | ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 |
ac_srcdir_defaulted=yes
# Try the directory containing this script, then the parent directory.
ac_confdir=`$as_dirname -- "$as_myself" ||
$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_myself" : 'X\(//\)[^/]' \| \
X"$as_myself" : 'X\(//\)$' \| \
X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_myself" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
1332 1333 1334 1335 1336 1337 1338 | # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF | | | 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 | # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures tcl 8.7 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. |
| ︙ | ︙ | |||
1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 | Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] | > | | > > | 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 |
Fine tuning of the installation directories:
--bindir=DIR user executables [EPREFIX/bin]
--sbindir=DIR system admin executables [EPREFIX/sbin]
--libexecdir=DIR program executables [EPREFIX/libexec]
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
--sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
--localstatedir=DIR modifiable single-machine data [PREFIX/var]
--runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
--libdir=DIR object code libraries [EPREFIX/lib]
--includedir=DIR C header files [PREFIX/include]
--oldincludedir=DIR C header files for non-gcc [/usr/include]
--datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
--datadir=DIR read-only architecture-independent data [DATAROOTDIR]
--infodir=DIR info documentation [DATAROOTDIR/info]
--localedir=DIR locale-dependent data [DATAROOTDIR/locale]
--mandir=DIR man documentation [DATAROOTDIR/man]
--docdir=DIR documentation root [DATAROOTDIR/doc/tcl]
--htmldir=DIR html documentation [DOCDIR]
--dvidir=DIR dvi documentation [DOCDIR]
--pdfdir=DIR pdf documentation [DOCDIR]
--psdir=DIR ps documentation [DOCDIR]
_ACEOF
cat <<\_ACEOF
_ACEOF
fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of tcl 8.7:";;
esac
cat <<\_ACEOF
Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--enable-shared build and link with shared libraries (default: on)
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 |
{ cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
| | | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
{ cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
continue
ac_builddir=.
case "$ac_dir" in
.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
*)
ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
# A ".." for each directory in $ac_dir_suffix.
ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
case $ac_top_builddir_sub in
"") ac_top_builddir_sub=. ac_top_build_prefix= ;;
*) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
esac ;;
esac
ac_abs_top_builddir=$ac_pwd
ac_abs_builddir=$ac_pwd$ac_dir_suffix
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
cd "$ac_dir" || { ac_status=$?; continue; }
| | > | | | | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | | < < < < | < | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < | < < < < < < < < < < < < < | < < < | < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | < < < < < < < < < < < | | | | 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 |
ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
ac_top_srcdir=$ac_top_build_prefix$srcdir
ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
esac
ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
cd "$ac_dir" || { ac_status=$?; continue; }
# Check for configure.gnu first; this name is used for a wrapper for
# Metaconfig's "Configure" on case-insensitive file systems.
if test -f "$ac_srcdir/configure.gnu"; then
echo &&
$SHELL "$ac_srcdir/configure.gnu" --help=recursive
elif test -f "$ac_srcdir/configure"; then
echo &&
$SHELL "$ac_srcdir/configure" --help=recursive
else
printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2
fi || ac_status=$?
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
tcl configure 8.7
generated by GNU Autoconf 2.70
Copyright (C) 2020 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
exit
fi
## ------------------------ ##
## Autoconf initialization. ##
## ------------------------ ##
# ac_fn_c_try_compile LINENO
# --------------------------
# Try to compile conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_compile ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
rm -f conftest.$ac_objext conftest.beam
if { { ac_try="$ac_compile"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compile") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest.$ac_objext
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_compile
# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
# -------------------------------------------------------
# Tests whether HEADER exists and can be compiled using the include files in
# INCLUDES, setting the cache variable VAR accordingly.
ac_fn_c_check_header_compile ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
printf %s "checking for $2... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
#include <$2>
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
eval "$3=yes"
else $as_nop
eval "$3=no"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_header_compile
# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
# -------------------------------------------
# Tests whether TYPE exists after having included INCLUDES, setting cache
# variable VAR accordingly.
ac_fn_c_check_type ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
printf %s "checking for $2... " >&6; }
if eval test \${$3+y}
then :
printf %s "(cached) " >&6
else $as_nop
eval "$3=no"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main (void)
{
if (sizeof ($2))
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
int
main (void)
{
if (sizeof (($2)))
return 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
else $as_nop
eval "$3=yes"
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
eval ac_res=\$$3
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
printf "%s\n" "$ac_res" >&6; }
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_type
# ac_fn_c_try_cpp LINENO
# ----------------------
# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_cpp ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
if { { ac_try="$ac_cpp conftest.$ac_ext"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } > conftest.i && {
test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
test ! -s conftest.err
}
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_cpp
ac_configure_args_raw=
for ac_arg
do
case $ac_arg in
*\'*)
ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
as_fn_append ac_configure_args_raw " '$ac_arg'"
done
case $ac_configure_args_raw in
*$as_nl*)
ac_safe_unquote= ;;
*)
ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab.
ac_unsafe_a="$ac_unsafe_z#~"
ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"
ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;
esac
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by tcl $as_me 8.7, which was
generated by GNU Autoconf 2.70. Invocation command line was
$ $0$ac_configure_args_raw
_ACEOF
exec 5>>config.log
{
cat <<_ASUNAME
## --------- ##
## Platform. ##
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 | _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS | > | > > > | | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 |
_ASUNAME
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
printf "%s\n" "PATH: $as_dir"
done
IFS=$as_save_IFS
} >&5
cat >&5 <<_ACEOF
|
| ︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 |
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
| | | 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 |
do
case $ac_arg in
-no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil)
continue ;;
*\'*)
ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
esac
case $ac_pass in
1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
2)
as_fn_append ac_configure_args1 " '$ac_arg'"
if test $ac_must_keep_next = true; then
ac_must_keep_next=false # Got value, back to normal.
|
| ︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 |
# When interrupted or exit'd, cleanup temporary files, and complete
# config.log. We remove comments because anyway the quotes in there
# would cause problems or look ugly.
# WARNING: Use '\'' to represent an apostrophe within the trap.
# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
# Save into config.log some information that might help in debugging.
{
echo
| > > | | | | 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 |
# When interrupted or exit'd, cleanup temporary files, and complete
# config.log. We remove comments because anyway the quotes in there
# would cause problems or look ugly.
# WARNING: Use '\'' to represent an apostrophe within the trap.
# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
trap 'exit_status=$?
# Sanitize IFS.
IFS=" "" $as_nl"
# Save into config.log some information that might help in debugging.
{
echo
printf "%s\n" "## ---------------- ##
## Cache variables. ##
## ---------------- ##"
echo
# The following way of writing the cache mishandles newlines in values,
(
for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
*) { eval $ac_var=; unset $ac_var;} ;;
esac ;;
esac
|
| ︙ | ︙ | |||
1941 1942 1943 1944 1945 1946 1947 |
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
| | | | | | | | | | | < | < < | < < | < < | < < | < < | < < < < | < < < < | < | < > | | > > > > > | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | > | > | 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 |
sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
;;
esac |
sort
)
echo
printf "%s\n" "## ----------------- ##
## Output variables. ##
## ----------------- ##"
echo
for ac_var in $ac_subst_vars
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
if test -n "$ac_subst_files"; then
printf "%s\n" "## ------------------- ##
## File substitutions. ##
## ------------------- ##"
echo
for ac_var in $ac_subst_files
do
eval ac_val=\$$ac_var
case $ac_val in
*\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
esac
printf "%s\n" "$ac_var='\''$ac_val'\''"
done | sort
echo
fi
if test -s confdefs.h; then
printf "%s\n" "## ----------- ##
## confdefs.h. ##
## ----------- ##"
echo
cat confdefs.h
echo
fi
test "$ac_signal" != 0 &&
printf "%s\n" "$as_me: caught signal $ac_signal"
printf "%s\n" "$as_me: exit $exit_status"
} >&5
rm -f core *.core core.conftest.* &&
rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
exit $exit_status
' 0
for ac_signal in 1 2 13 15; do
trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal
done
ac_signal=0
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -f -r conftest* confdefs.h
printf "%s\n" "/* confdefs.h */" > confdefs.h
# Predefined preprocessor variables.
printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h
printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h
# Let the site file select an alternate cache file if it wants to.
# Prefer an explicitly selected file to automatically selected ones.
if test -n "$CONFIG_SITE"; then
ac_site_files="$CONFIG_SITE"
elif test "x$prefix" != xNONE; then
ac_site_files="$prefix/share/config.site $prefix/etc/config.site"
else
ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
fi
for ac_site_file in $ac_site_files
do
case $ac_site_file in #(
*/*) :
;; #(
*) :
ac_site_file=./$ac_site_file ;;
esac
if test -f "$ac_site_file" && test -r "$ac_site_file"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}
sed 's/^/| /' "$ac_site_file" >&5
. "$ac_site_file" \
|| { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "failed to load site script $ac_site_file
See \`config.log' for more details" "$LINENO" 5; }
fi
done
if test -r "$cache_file"; then
# Some versions of bash will fail to source /dev/null (special files
# actually), so we avoid doing that. DJGPP emulates it as a regular file.
if test /dev/null != "$cache_file" && test -f "$cache_file"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
printf "%s\n" "$as_me: loading cache $cache_file" >&6;}
case $cache_file in
[\\/]* | ?:[\\/]* ) . "$cache_file";;
*) . "./$cache_file";;
esac
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
printf "%s\n" "$as_me: creating cache $cache_file" >&6;}
>$cache_file
fi
# Test code for whether the C compiler supports C89 (global declarations)
ac_c_conftest_c89_globals='
/* Does the compiler advertise C89 conformance?
Do not test the value of __STDC__, because some compilers set it to 0
while being otherwise adequately conformant. */
#if !defined __STDC__
# error "Compiler does not advertise C89 conformance"
#endif
#include <stddef.h>
#include <stdarg.h>
struct stat;
/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */
struct buf { int x; };
struct buf * (*rcsopen) (struct buf *, struct stat *, int);
static char *e (p, i)
char **p;
int i;
{
return p[i];
}
static char *f (char * (*g) (char **, int), char **p, ...)
{
char *s;
va_list v;
va_start (v,p);
s = g (p, va_arg (v,int));
va_end (v);
return s;
}
/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
function prototypes and stuff, but not \xHH hex character constants.
These do not provoke an error unfortunately, instead are silently treated
as an "x". The following induces an error, until -std is added to get
proper ANSI mode. Curiously \x00 != x always comes out true, for an
array size at least. It is necessary to write \x00 == 0 to get something
that is true only with -std. */
int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];
/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
inside strings and character constants. */
#define FOO(x) '\''x'\''
int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];
int test (int i, double x);
struct s1 {int (*f) (int a);};
struct s2 {int (*f) (double a);};
int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),
int, int);'
# Test code for whether the C compiler supports C89 (body of main).
ac_c_conftest_c89_main='
ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);
'
# Test code for whether the C compiler supports C99 (global declarations)
ac_c_conftest_c99_globals='
// Does the compiler advertise C99 conformance?
#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
# error "Compiler does not advertise C99 conformance"
#endif
#include <stdbool.h>
extern int puts (const char *);
extern int printf (const char *, ...);
extern int dprintf (int, const char *, ...);
extern void *malloc (size_t);
// Check varargs macros. These examples are taken from C99 6.10.3.5.
// dprintf is used instead of fprintf to avoid needing to declare
// FILE and stderr.
#define debug(...) dprintf (2, __VA_ARGS__)
#define showlist(...) puts (#__VA_ARGS__)
#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))
static void
test_varargs_macros (void)
{
int x = 1234;
int y = 5678;
debug ("Flag");
debug ("X = %d\n", x);
showlist (The first, second, and third items.);
report (x>y, "x is %d but y is %d", x, y);
}
// Check long long types.
#define BIG64 18446744073709551615ull
#define BIG32 4294967295ul
#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)
#if !BIG_OK
#error "your preprocessor is broken"
#endif
#if BIG_OK
#else
#error "your preprocessor is broken"
#endif
static long long int bignum = -9223372036854775807LL;
static unsigned long long int ubignum = BIG64;
struct incomplete_array
{
int datasize;
double data[];
};
struct named_init {
int number;
const wchar_t *name;
double average;
};
typedef const char *ccp;
static inline int
test_restrict (ccp restrict text)
{
// See if C++-style comments work.
// Iterate through items via the restricted pointer.
// Also check for declarations in for loops.
for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)
continue;
return 0;
}
// Check varargs and va_copy.
static bool
test_varargs (const char *format, ...)
{
va_list args;
va_start (args, format);
va_list args_copy;
va_copy (args_copy, args);
const char *str = "";
int number = 0;
float fnumber = 0;
while (*format)
{
switch (*format++)
{
case '\''s'\'': // string
str = va_arg (args_copy, const char *);
break;
case '\''d'\'': // int
number = va_arg (args_copy, int);
break;
case '\''f'\'': // float
fnumber = va_arg (args_copy, double);
break;
default:
break;
}
}
va_end (args_copy);
va_end (args);
return *str && number && fnumber;
}
'
# Test code for whether the C compiler supports C99 (body of main).
ac_c_conftest_c99_main='
// Check bool.
_Bool success = false;
success |= (argc != 0);
// Check restrict.
if (test_restrict ("String literal") == 0)
success = true;
char *restrict newvar = "Another string";
// Check varargs.
success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);
test_varargs_macros ();
// Check flexible array members.
struct incomplete_array *ia =
malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));
ia->datasize = 10;
for (int i = 0; i < ia->datasize; ++i)
ia->data[i] = i * 1.234;
// Check named initializers.
struct named_init ni = {
.number = 34,
.name = L"Test wide string",
.average = 543.34343,
};
ni.number = 58;
int dynamic_array[ni.number];
dynamic_array[0] = argv[0][0];
dynamic_array[ni.number - 1] = 543;
// work around unused variable warnings
ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''
|| dynamic_array[ni.number - 1] != 543);
'
# Test code for whether the C compiler supports C11 (global declarations)
ac_c_conftest_c11_globals='
// Does the compiler advertise C11 conformance?
#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L
# error "Compiler does not advertise C11 conformance"
#endif
// Check _Alignas.
char _Alignas (double) aligned_as_double;
char _Alignas (0) no_special_alignment;
extern char aligned_as_int;
char _Alignas (0) _Alignas (int) aligned_as_int;
// Check _Alignof.
enum
{
int_alignment = _Alignof (int),
int_array_alignment = _Alignof (int[100]),
char_alignment = _Alignof (char)
};
_Static_assert (0 < -_Alignof (int), "_Alignof is signed");
// Check _Noreturn.
int _Noreturn does_not_return (void) { for (;;) continue; }
// Check _Static_assert.
struct test_static_assert
{
int x;
_Static_assert (sizeof (int) <= sizeof (long int),
"_Static_assert does not work in struct");
long int y;
};
// Check UTF-8 literals.
#define u8 syntax error!
char const utf8_literal[] = u8"happens to be ASCII" "another string";
// Check duplicate typedefs.
typedef long *long_ptr;
typedef long int *long_ptr;
typedef long_ptr long_ptr;
// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.
struct anonymous
{
union {
struct { int i; int j; };
struct { int k; long int l; } w;
};
int m;
} v1;
'
# Test code for whether the C compiler supports C11 (body of main).
ac_c_conftest_c11_main='
_Static_assert ((offsetof (struct anonymous, i)
== offsetof (struct anonymous, w.k)),
"Anonymous union alignment botch");
v1.i = 2;
v1.w.k = 5;
ok |= v1.i != 5;
'
# Test code for whether the C compiler supports C11 (complete).
ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}
${ac_c_conftest_c99_globals}
${ac_c_conftest_c11_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
${ac_c_conftest_c99_main}
${ac_c_conftest_c11_main}
return ok;
}
"
# Test code for whether the C compiler supports C99 (complete).
ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}
${ac_c_conftest_c99_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
${ac_c_conftest_c99_main}
return ok;
}
"
# Test code for whether the C compiler supports C89 (complete).
ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}
int
main (int argc, char **argv)
{
int ok = 0;
${ac_c_conftest_c89_main}
return ok;
}
"
as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"
as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"
as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"
as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"
as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"
as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"
as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"
as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"
as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"
# Check that the precious variables saved in the cache have kept the same
# value.
ac_cache_corrupted=false
for ac_var in $ac_precious_vars; do
eval ac_old_set=\$ac_cv_env_${ac_var}_set
eval ac_new_set=\$ac_env_${ac_var}_set
eval ac_old_val=\$ac_cv_env_${ac_var}_value
eval ac_new_val=\$ac_env_${ac_var}_value
case $ac_old_set,$ac_new_set in
set,)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
ac_cache_corrupted=: ;;
,set)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5
printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
ac_cache_corrupted=: ;;
,);;
*)
if test "x$ac_old_val" != "x$ac_new_val"; then
# differences in whitespace do not lead to failure.
ac_old_val_w=`echo x $ac_old_val`
ac_new_val_w=`echo x $ac_new_val`
if test "$ac_old_val_w" != "$ac_new_val_w"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5
printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
ac_cache_corrupted=:
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5
printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}
eval $ac_var=\$ac_old_val
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5
printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;}
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5
printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;}
fi;;
esac
# Pass precious variables to config.status.
if test "$ac_new_set" = set; then
case $ac_new_val in
*\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
*) ac_arg=$ac_var=$ac_new_val ;;
esac
case " $ac_configure_args " in
*" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
*) as_fn_append ac_configure_args " '$ac_arg'" ;;
esac
fi
done
if $ac_cache_corrupted; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}
as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file'
and start over" "$LINENO" 5
fi
## -------------------- ##
## Main body of script. ##
## -------------------- ##
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
# The following define is needed when building with Cygwin since newer
# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
|
| ︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 |
#------------------------------------------------------------------------
# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
set dummy ${ac_tool_prefix}gcc; ac_word=$2
| > > > > > > > > > | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | > | | | > | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | > | | | | > | | | | > > | | | | > | | | | > | | | > | | | > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > | | | | | | | | | > | | | > > > > > > > > > | | | > | | | | | > | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | | | | > | | | | | | | > < | < < | | | | > | < < < < < < < < | | | | | | | | > | | | < | < > | | | > > > > > > > > > > | | | | | | > | > > | | | > | | | | | | | > | | > | > > > | | | | | | | | | > | | > | > > > | | | | | | | | | > | | | | > | | | | | 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 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 |
#------------------------------------------------------------------------
# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
set dummy ${ac_tool_prefix}gcc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}gcc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="gcc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
else
CC="$ac_cv_prog_CC"
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
set dummy ${ac_tool_prefix}cc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}cc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
fi
if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
ac_prog_rejected=no
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
ac_prog_rejected=yes
continue
fi
ac_cv_prog_CC="cc"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
if test $ac_prog_rejected = yes; then
# We found a bogon in the path, so make sure we never use it.
set dummy $ac_cv_prog_CC
shift
if test $# != 0; then
# We chose a different compiler from the bogus one.
# However, it has the same basename, so the bogon will be chosen
# first if we set CC to just the basename; use the full file name.
shift
ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"
fi
fi
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
for ac_prog in cl.exe
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
test -n "$CC" && break
done
fi
if test -z "$CC"; then
ac_ct_CC=$CC
for ac_prog in cl.exe
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="$ac_prog"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
test -n "$ac_ct_CC" && break
done
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
fi
fi
if test -z "$CC"; then
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.
set dummy ${ac_tool_prefix}clang; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}clang"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
CC=$ac_cv_prog_CC
if test -n "$CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
printf "%s\n" "$CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_CC"; then
ac_ct_CC=$CC
# Extract the first word of "clang", so it can be a program name with args.
set dummy clang; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_CC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_CC"; then
ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="clang"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_CC=$ac_cv_prog_ac_ct_CC
if test -n "$ac_ct_CC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
printf "%s\n" "$ac_ct_CC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_CC" = x; then
CC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
CC=$ac_ct_CC
fi
else
CC="$ac_cv_prog_CC"
fi
fi
test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "no acceptable C compiler found in \$PATH
See \`config.log' for more details" "$LINENO" 5; }
# Provide some information about the compiler.
printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
set X $ac_compile
ac_compiler=$2
for ac_option in --version -v -V -qversion -version; do
{ { ac_try="$ac_compiler $ac_option >&5"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compiler $ac_option >&5") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
sed '10a\
... rest of stderr output deleted ...
10q' conftest.err >conftest.er1
cat conftest.er1 >&5
fi
rm -f conftest.er1 conftest.err
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
done
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
# Try to create an executable without -o first, disregard a.out.
# It will help us diagnose broken compilers, and finding out an intuition
# of exeext.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
printf %s "checking whether the C compiler works... " >&6; }
ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
# The possible output files:
ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
ac_rmfiles=
for ac_file in $ac_files
do
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
* ) ac_rmfiles="$ac_rmfiles $ac_file";;
esac
done
rm -f $ac_rmfiles
if { { ac_try="$ac_link_default"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link_default") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
# Autoconf-2.13 could set the ac_cv_exeext variable to `no'.
# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'
# in a Makefile. We should not override ac_cv_exeext if it was cached,
# so that the user can short-circuit this test for compilers unknown to
# Autoconf.
for ac_file in $ac_files ''
do
test -f "$ac_file" || continue
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
;;
[ab].out )
# We found the default executable, but exeext='' is most
# certainly right.
break;;
*.* )
if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;
then :; else
ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
fi
# We set ac_cv_exeext here because the later test for it is not
# safe: cross compilers may not add the suffix if given an `-o'
# argument, so we may need to know it at that point already.
# Even if this section looks crufty: it has the advantage of
# actually working.
break;;
* )
break;;
esac
done
test "$ac_cv_exeext" = no && ac_cv_exeext=
else $as_nop
ac_file=''
fi
if test -z "$ac_file"
then :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error 77 "C compiler cannot create executables
See \`config.log' for more details" "$LINENO" 5; }
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
printf %s "checking for C compiler default output file name... " >&6; }
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
printf "%s\n" "$ac_file" >&6; }
ac_exeext=$ac_cv_exeext
rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
ac_clean_files=$ac_clean_files_save
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
printf %s "checking for suffix of executables... " >&6; }
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
# If both `conftest.exe' and `conftest' are `present' (well, observable)
# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will
# work properly (i.e., refer to `conftest.exe'), while it won't with
# `rm'.
for ac_file in conftest.exe conftest conftest.*; do
test -f "$ac_file" || continue
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
*.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
break;;
* ) break;;
esac
done
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot compute suffix of executables: cannot compile and link
See \`config.log' for more details" "$LINENO" 5; }
fi
rm -f conftest conftest$ac_cv_exeext
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
printf "%s\n" "$ac_cv_exeext" >&6; }
rm -f conftest.$ac_ext
EXEEXT=$ac_cv_exeext
ac_exeext=$EXEEXT
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdio.h>
int
main (void)
{
FILE *f = fopen ("conftest.out", "w");
return ferror (f) || fclose (f) != 0;
;
return 0;
}
_ACEOF
ac_clean_files="$ac_clean_files conftest.out"
# Check that the compiler produces executables we can run. If not, either
# the compiler is broken, or we cross compile.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
printf %s "checking whether we are cross compiling... " >&6; }
if test "$cross_compiling" != yes; then
{ { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
if { ac_try='./conftest$ac_cv_exeext'
{ { case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_try") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }; }; then
cross_compiling=no
else
if test "$cross_compiling" = maybe; then
cross_compiling=yes
else
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error 77 "cannot run C compiled programs.
If you meant to cross compile, use \`--host'.
See \`config.log' for more details" "$LINENO" 5; }
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
printf "%s\n" "$cross_compiling" >&6; }
rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out
ac_clean_files=$ac_clean_files_save
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
printf %s "checking for suffix of object files... " >&6; }
if test ${ac_cv_objext+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
rm -f conftest.o conftest.obj
if { { ac_try="$ac_compile"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_compile") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }
then :
for ac_file in conftest.o conftest.obj conftest.*; do
test -f "$ac_file" || continue;
case $ac_file in
*.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
*) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
break;;
esac
done
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot compute suffix of object files: cannot compile
See \`config.log' for more details" "$LINENO" 5; }
fi
rm -f conftest.$ac_cv_objext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
printf "%s\n" "$ac_cv_objext" >&6; }
OBJEXT=$ac_cv_objext
ac_objext=$OBJEXT
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5
printf %s "checking whether the compiler supports GNU C... " >&6; }
if test ${ac_cv_c_compiler_gnu+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
#ifndef __GNUC__
choke me
#endif
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_compiler_gnu=yes
else $as_nop
ac_compiler_gnu=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_cv_c_compiler_gnu=$ac_compiler_gnu
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }
ac_compiler_gnu=$ac_cv_c_compiler_gnu
if test $ac_compiler_gnu = yes; then
GCC=yes
else
GCC=
fi
ac_test_CFLAGS=${CFLAGS+y}
ac_save_CFLAGS=$CFLAGS
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
printf %s "checking whether $CC accepts -g... " >&6; }
if test ${ac_cv_prog_cc_g+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_save_c_werror_flag=$ac_c_werror_flag
ac_c_werror_flag=yes
ac_cv_prog_cc_g=no
CFLAGS="-g"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_g=yes
else $as_nop
CFLAGS=""
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
else $as_nop
ac_c_werror_flag=$ac_save_c_werror_flag
CFLAGS="-g"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_g=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
ac_c_werror_flag=$ac_save_c_werror_flag
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
printf "%s\n" "$ac_cv_prog_cc_g" >&6; }
if test $ac_test_CFLAGS; then
CFLAGS=$ac_save_CFLAGS
elif test $ac_cv_prog_cc_g = yes; then
if test "$GCC" = yes; then
CFLAGS="-g -O2"
else
CFLAGS="-g"
fi
else
if test "$GCC" = yes; then
CFLAGS="-O2"
else
CFLAGS=
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5
printf %s "checking for $CC option to enable C11 features... " >&6; }
if test ${ac_cv_prog_cc_c11+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c11=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c11_program
_ACEOF
for ac_arg in '' -std=gnu11
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c11=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c11" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c11" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c11"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5
printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c11" != xno
then :
ac_prog_cc_stdc=c11
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5
printf %s "checking for $CC option to enable C99 features... " >&6; }
if test ${ac_cv_prog_cc_c99+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c99=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c89_program
_ACEOF
for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc1x -qlanglvl=extc99
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c99=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c99" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c99" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c99"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5
printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c99" != xno
then :
ac_prog_cc_stdc=c99
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99
else $as_nop
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5
printf %s "checking for $CC option to enable C89 features... " >&6; }
if test ${ac_cv_prog_cc_c89+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_prog_cc_c89=no
ac_save_CC=$CC
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$ac_c_conftest_c89_program
_ACEOF
for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \
-Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
do
CC="$ac_save_CC $ac_arg"
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_prog_cc_c89=$ac_arg
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam
test "x$ac_cv_prog_cc_c89" != "xno" && break
done
rm -f conftest.$ac_ext
CC=$ac_save_CC
fi
# AC_CACHE_VAL
ac_prog_cc_stdc_options=
case "x$ac_cv_prog_cc_c89" in #(
x) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
printf "%s\n" "none needed" >&6; } ;; #(
xno) :
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
printf "%s\n" "unsupported" >&6; } ;; #(
*) :
ac_prog_cc_stdc_options=" $ac_cv_prog_cc_c89"
CC="$CC$ac_prog_cc_stdc_options"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } ;;
esac
if test "x$ac_cv_prog_cc_c89" != xno
then :
ac_prog_cc_stdc=c89
ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89
else $as_nop
ac_prog_cc_stdc=no
ac_cv_prog_cc_stdc=no
fi
fi
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
printf %s "checking for inline... " >&6; }
if test ${ac_cv_c_inline+y}
then :
printf %s "(cached) " >&6
else $as_nop
ac_cv_c_inline=no
for ac_kw in inline __inline__ __inline; do
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef __cplusplus
typedef int foo_t;
static $ac_kw foo_t static_foo (void) {return 0; }
$ac_kw foo_t foo (void) {return 0; }
#endif
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_c_inline=$ac_kw
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
test "$ac_cv_c_inline" != no && break
done
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
printf "%s\n" "$ac_cv_c_inline" >&6; }
case $ac_cv_c_inline in
inline | yes) ;;
*)
case $ac_cv_c_inline in
no) ac_val=;;
*) ac_val=$ac_cv_c_inline;;
esac
cat >>confdefs.h <<_ACEOF
#ifndef __cplusplus
#define inline $ac_val
#endif
_ACEOF
;;
esac
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
set dummy ${ac_tool_prefix}ar; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_AR+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_AR="${ac_tool_prefix}ar"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
AR=$ac_cv_prog_AR
if test -n "$AR"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
printf "%s\n" "$AR" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_AR"; then
ac_ct_AR=$AR
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_AR+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_AR"; then
ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_AR="ar"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_AR=$ac_cv_prog_ac_ct_AR
if test -n "$ac_ct_AR"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
printf "%s\n" "$ac_ct_AR" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_AR" = x; then
AR=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
AR=$ac_ct_AR
fi
else
AR="$ac_cv_prog_AR"
fi
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
set dummy ${ac_tool_prefix}ranlib; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_RANLIB+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
RANLIB=$ac_cv_prog_RANLIB
if test -n "$RANLIB"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
printf "%s\n" "$RANLIB" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_RANLIB"; then
ac_ct_RANLIB=$RANLIB
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_RANLIB+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_RANLIB"; then
ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RANLIB="ranlib"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
if test -n "$ac_ct_RANLIB"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
printf "%s\n" "$ac_ct_RANLIB" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_RANLIB" = x; then
RANLIB=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
RANLIB=$ac_ct_RANLIB
fi
else
RANLIB="$ac_cv_prog_RANLIB"
fi
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args.
set dummy ${ac_tool_prefix}windres; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_RC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$RC"; then
ac_cv_prog_RC="$RC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_RC="${ac_tool_prefix}windres"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
RC=$ac_cv_prog_RC
if test -n "$RC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RC" >&5
printf "%s\n" "$RC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
fi
if test -z "$ac_cv_prog_RC"; then
ac_ct_RC=$RC
# Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_ac_ct_RC+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$ac_ct_RC"; then
ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RC="windres"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
ac_ct_RC=$ac_cv_prog_ac_ct_RC
if test -n "$ac_ct_RC"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5
printf "%s\n" "$ac_ct_RC" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
if test "x$ac_ct_RC" = x; then
RC=""
else
case $cross_compiling:$ac_tool_warned in
yes:)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
ac_tool_warned=yes ;;
esac
RC=$ac_ct_RC
fi
else
RC="$ac_cv_prog_RC"
fi
#--------------------------------------------------------------------
# Checks to see if the make program sets the $MAKE variable.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5
printf %s "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; }
set x ${MAKE-make}
ac_make=`printf "%s\n" "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'`
if eval test \${ac_cv_prog_make_${ac_make}_set+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat >conftest.make <<\_ACEOF
SHELL = /bin/sh
all:
@echo '@@@%%%=$(MAKE)=@@@%%%'
_ACEOF
# GNU make sometimes prints "make[1]: Entering ...", which would confuse us.
case `${MAKE-make} -f conftest.make 2>/dev/null` in
*@@@%%%=?*=@@@%%%*)
eval ac_cv_prog_make_${ac_make}_set=yes;;
*)
eval ac_cv_prog_make_${ac_make}_set=no;;
esac
rm -f conftest.make
fi
if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
SET_MAKE=
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
SET_MAKE="MAKE=${MAKE-make}"
fi
#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------
#------------------------------------------------------------------------
# Embedded configuration information, encoding to use for the values, TIP #59
#------------------------------------------------------------------------
# Check whether --with-encoding was given.
if test ${with_encoding+y}
then :
withval=$with_encoding; with_tcencoding=${withval}
fi
if test x"${with_tcencoding}" != x ; then
printf "%s\n" "#define TCL_CFGVAL_ENCODING \"${with_tcencoding}\"" >>confdefs.h
else
printf "%s\n" "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
printf %s "checking how to build libraries... " >&6; }
# Check whether --enable-shared was given.
if test ${enable_shared+y}
then :
enableval=$enable_shared; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5
printf "%s\n" "shared" >&6; }
SHARED_BUILD=1
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5
printf "%s\n" "static" >&6; }
SHARED_BUILD=0
printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check whether --enable-time64bit was given.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5
printf %s "checking force of 64-bit time_t... " >&6; }
# Check whether --enable-time64bit was given.
if test ${enable_time64bit+y}
then :
enableval=$enable_time64bit; tcl_ok=$enableval
else $as_nop
tcl_ok=no
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5
printf "%s\n" "\"$tcl_ok\"" >&6; }
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
ac_header= ac_cache=
for ac_item in $ac_header_c_list
do
if test $ac_cache; then
ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"
if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then
printf "%s\n" "#define $ac_item 1" >> confdefs.h
fi
ac_header= ac_cache=
elif test $ac_header; then
ac_cache=$ac_item
else
ac_header=$ac_item
fi
done
if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes
then :
printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h
fi
# Step 0: Enable 64 bit support?
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
printf %s "checking if 64bit support is requested... " >&6; }
# Check whether --enable-64bit was given.
if test ${enable_64bit+y}
then :
enableval=$enable_64bit; do64bit=$enableval
else $as_nop
do64bit=no
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
printf "%s\n" "$do64bit" >&6; }
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h
# Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_CYGPATH+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$CYGPATH"; then
ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_CYGPATH="cygpath -m"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo"
fi
fi
CYGPATH=$ac_cv_prog_CYGPATH
if test -n "$CYGPATH"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5
printf "%s\n" "$CYGPATH" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
# Extract the first word of "wine", so it can be a program name with args.
set dummy wine; ac_word=$2
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
printf %s "checking for $ac_word... " >&6; }
if test ${ac_cv_prog_WINE+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -n "$WINE"; then
ac_cv_prog_WINE="$WINE" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
ac_cv_prog_WINE="wine"
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
fi
fi
WINE=$ac_cv_prog_WINE
if test -n "$WINE"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $WINE" >&5
printf "%s\n" "$WINE" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
fi
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
# which requires x86|amd64|ia64.
MACHINE="X86"
if test "$GCC" = "yes"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5
printf %s "checking for cross-compile version of gcc... " >&6; }
if test ${ac_cv_cross+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef _WIN32
#error cross-compiler
#endif
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_cross=no
else $as_nop
ac_cv_cross=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5
printf "%s\n" "$ac_cv_cross" >&6; }
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
amd64|x64|yes)
CC="x86_64-w64-mingw32-${CC}"
LD="x86_64-w64-mingw32-ld"
AR="x86_64-w64-mingw32-ar"
|
| ︙ | ︙ | |||
4002 4003 4004 4005 4006 4007 4008 |
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
conftest=/tmp/conftest.rc
echo "STRINGTABLE BEGIN" > $conftest
echo "101 \"name\"" >> $conftest
echo "END" >> $conftest
| | | | | | | | | | | > | | | | > | | | | | | | > | | | | | > | | | | | > | | | | | | | | | | | | | | | | | | | 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 |
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
conftest=/tmp/conftest.rc
echo "STRINGTABLE BEGIN" > $conftest
echo "101 \"name\"" >> $conftest
echo "END" >> $conftest
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Windows native path bug in windres" >&5
printf %s "checking for Windows native path bug in windres... " >&6; }
cyg_conftest=`$CYGPATH $conftest`
if { ac_try='$RC -o conftest.res.o $cyg_conftest'
{ { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_try\""; } >&5
(eval $ac_try) 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }; } ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
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"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5
printf %s "checking for mingw32 version of gcc... " >&6; }
if test ${ac_cv_win32+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifdef _WIN32
#error win32
#endif
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
ac_cv_win32=no
else $as_nop
ac_cv_win32=yes
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
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
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}
then :
printf %s "(cached) " >&6
else $as_nop
# ac_fn_c_try_link LINENO
# -----------------------
# Try to link conftest.$ac_ext, and return whether this succeeded.
ac_fn_c_try_link ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>conftest.err
ac_status=$?
if test -s conftest.err; then
grep -v '^ *+' conftest.err >conftest.er1
cat conftest.er1 >&5
mv -f conftest.er1 conftest.err
fi
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest$ac_exeext && {
test "$cross_compiling" = yes ||
test -x conftest$ac_exeext
}
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=1
fi
# Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
# created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
# interfere with the next link command; also delete a directory that is
# left behind by Apple's compiler. We do this before executing the actions.
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_link
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <windows.h>
int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
ac_cv_municode=yes
else $as_nop
ac_cv_municode=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_municode" >&5
printf "%s\n" "$ac_cv_municode" >&6; }
CFLAGS=$hold_cflags
if test "$ac_cv_municode" = "yes" ; then
extra_ldflags="$extra_ldflags -municode"
else
extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
fi
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=""
SHLIB_LD_LIBS='${LIBS}'
LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32"
# mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't
LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32"
STLIB_LD='${AR} cr'
RC_OUT=-o
RC_TYPE=
RC_INCLUDE=--include
RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \$@"
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}"
fi
# Link with gcc since ld does not link to default libs like
# -luser32 and -lmsvcrt by default.
SHLIB_LD='${CC} -shared'
SHLIB_LD_LIBS='${LIBS}'
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\$@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".a"
LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement"
;;
esac
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \$@"
CC_EXENAME="-o \$@"
|
| ︙ | ︙ | |||
4250 4251 4252 4253 4254 4255 4256 |
#LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}"
LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}"
LDFLAGS_WINDOW="-mwindows ${extra_ldflags}"
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
| | | | | | | > | | | | | | | | | | | | | | | | 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 |
#LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}"
LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}"
LDFLAGS_WINDOW="-mwindows ${extra_ldflags}"
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
;;
ia64)
MACHINE="IA64"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
;;
*)
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#ifndef _WIN64
#error 32-bit
#endif
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_win_64bit=yes
else $as_nop
tcl_win_64bit=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
if test "$tcl_win_64bit" = "yes" ; then
do64bit=amd64
MACHINE="AMD64"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
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]*)
lflags="${lflags} -nodefaultlib:libucrt.lib"
;;
*)
;;
esac
fi
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".lib"
LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
MACHINE="IA64"
;;
esac
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
printf "%s\n" " Using 64-bit $MACHINE mode" >&6; }
fi
LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
LIBS="$LIBS ucrt.lib"
|
| ︙ | ︙ | |||
4405 4406 4407 4408 4409 4410 4411 |
else
LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
fi
fi
if test "$do64bit" != "no" ; then
| | | | | > | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | > | < | | | > | | | | > | | | | | | 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 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 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 |
else
LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
fi
fi
if test "$do64bit" != "no" ; then
printf "%s\n" "#define TCL_CFG_DO64BIT 1" >>confdefs.h
fi
if test "${GCC}" = "yes" ; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5
printf %s "checking for SEH support in compiler... " >&6; }
if test ${tcl_cv_seh+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test "$cross_compiling" = yes
then :
tcl_cv_seh=no
else $as_nop
# ac_fn_c_try_run LINENO
# ----------------------
# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that
# executables *can* be run.
ac_fn_c_try_run ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
if { { ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_link") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
{ { case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
printf "%s\n" "$ac_try_echo"; } >&5
(eval "$ac_try") 2>&5
ac_status=$?
printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
test $ac_status = 0; }; }
then :
ac_retval=0
else $as_nop
printf "%s\n" "$as_me: program exited with status $ac_status" >&5
printf "%s\n" "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_retval=$ac_status
fi
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_run
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int main(int argc, char** argv) {
int a, b = 0;
__try {
a = 666 / b;
}
__except (EXCEPTION_EXECUTE_HANDLER) {
return 0;
}
return 1;
}
_ACEOF
if ac_fn_c_try_run "$LINENO"
then :
tcl_cv_seh=yes
else $as_nop
tcl_cv_seh=no
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5
printf "%s\n" "$tcl_cv_seh" >&6; }
if test "$tcl_cv_seh" = "no" ; then
printf "%s\n" "#define HAVE_NO_SEH 1" >>confdefs.h
fi
#
# Check to see if the excpt.h include file provided contains the
# definition for EXCEPTION_DISPOSITION; if not, which is the case
# with Cygwin's version as of 2002-04-10, define it to be int,
# sufficient for getting the current code to work.
#
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5
printf %s "checking for EXCEPTION_DISPOSITION support in include files... " >&6; }
if test ${tcl_cv_eh_disposition+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
# define WIN32_LEAN_AND_MEAN
# include <windows.h>
# undef WIN32_LEAN_AND_MEAN
int
main (void)
{
EXCEPTION_DISPOSITION x;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_eh_disposition=yes
else $as_nop
tcl_cv_eh_disposition=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5
printf "%s\n" "$tcl_cv_eh_disposition" >&6; }
if test "$tcl_cv_eh_disposition" = "no" ; then
printf "%s\n" "#define EXCEPTION_DISPOSITION int" >>confdefs.h
fi
# Check to see if winnt.h defines CHAR, SHORT, and LONG
# even if VOID has already been #defined. The win32api
# used by mingw and cygwin is known to do this.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5
printf %s "checking for winnt.h that ignores VOID define... " >&6; }
if test ${tcl_cv_winnt_ignore_void+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define VOID void
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int
main (void)
{
CHAR c;
SHORT s;
LONG l;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_winnt_ignore_void=yes
else $as_nop
tcl_cv_winnt_ignore_void=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5
printf "%s\n" "$tcl_cv_winnt_ignore_void" >&6; }
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
printf "%s\n" "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h
fi
ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
if test "x$ac_cv_header_stdbool_h" = xyes
then :
printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h
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.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
printf %s "checking for cast to union support... " >&6; }
if test ${tcl_cv_cast_to_union+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int
main (void)
{
union foo { int i; double d; };
union foo f = (union foo) (int) 0;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_cast_to_union=yes
else $as_nop
tcl_cv_cast_to_union=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
printf "%s\n" "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
fi
# DL_LIBS is empty, but then we match the Unix version
|
| ︙ | ︙ | |||
4617 4618 4619 4620 4621 4622 4623 | #------------------------------------------------------------------------ # Add stuff for zlib/libtommath; note that this is mostly done in the # makefile now as we just assume that the platform hasn't got usable # z.lib/tommath.lib #------------------------------------------------------------------------ | | > | | > | | > | | > | | | | | < | < | < | < < < < < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < > | < | < | < | < < < < < | < < < < < < < < | < < < | | < | < < < < < < < < < < < < < < < < < < < < < | > | | | | > | | | 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 |
#------------------------------------------------------------------------
# Add stuff for zlib/libtommath; note that this is mostly done in the
# makefile now as we just assume that the platform hasn't got usable
# z.lib/tommath.lib
#------------------------------------------------------------------------
if test "${enable_shared+set}" = "set"
then :
enableval="$enable_shared"
tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = "yes"
then :
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
TOMMATH_DLL_FILE=\${TOMMATH_DLL_FILE}
printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
if test "$do64bit" != "no"
then :
printf "%s\n" "#define MP_64BIT 1" >>confdefs.h
if test "$GCC" == "yes"
then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a
else $as_nop
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib
fi
else $as_nop
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win32/tommath.lib
fi
else $as_nop
ZLIB_OBJS=\${ZLIB_OBJS}
TOMMATH_OBJS=\${TOMMATH_OBJS}
fi
printf "%s\n" "#define HAVE_ZLIB 1" >>confdefs.h
ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "
#include <stdint.h>
"
if test "x$ac_cv_type_intptr_t" = xyes
then :
printf "%s\n" "#define HAVE_INTPTR_T 1" >>confdefs.h
fi
ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "
#include <stdint.h>
"
if test "x$ac_cv_type_uintptr_t" = xyes
then :
printf "%s\n" "#define HAVE_UINTPTR_T 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
# Check whether --enable-zipfs was given.
if test ${enable_zipfs+y}
then :
enableval=$enable_zipfs; tcl_ok=$enableval
else $as_nop
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; 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 $as_nop
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
|
| ︙ | ︙ | |||
4832 4833 4834 4835 4836 4837 4838 | # 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' | | | | > | | | | | | | > | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | | | | > | | | | | | | | > | < | | | | < | | | | | | | | | < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | > | | | < < < < > | > > > | < < | | < < < | < < < < | < | | | 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 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 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 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 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 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 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 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 5419 5420 5421 5422 5423 5424 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 5453 5454 5455 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 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 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 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 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 5711 5712 5713 5714 5715 5716 5717 5718 5719 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 |
# 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 $as_nop
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
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
#
# Find a native zip implementation
#
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
printf %s "checking for tclsh... " >&6; }
if test ${ac_cv_path_tclsh+y}
then :
printf %s "(cached) " >&6
else $as_nop
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/tclsh[8-9]*.exe 2> /dev/null` \
`ls -r $dir/tclsh* 2> /dev/null` ; do
if test x"$ac_cv_path_tclsh" = x ; then
if test -f "$j" ; then
ac_cv_path_tclsh=$j
break
fi
fi
done
done
fi
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
printf "%s\n" "$TCLSH_PROG" >&6; }
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
printf "%s\n" "No tclsh found on PATH" >&6; }
fi
ZIP_PROG=""
ZIP_PROG_OPTIONS=""
ZIP_PROG_VFSSEARCH=""
ZIP_INSTALL_OBJS=""
{ 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 $as_nop
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
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
ZIPFS_BUILD=1
TCL_ZIP_FILE=libtcl_${TCL_MAJOR_VERSION}_${TCL_MINOR_VERSION}_${TCL_PATCH_LEVEL}.zip
else
ZIPFS_BUILD=0
TCL_ZIP_FILE=
fi
# Do checking message here to not mess up interleaved configure output
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for building with zipfs" >&5
printf %s "checking for building with zipfs... " >&6; }
if test "${ZIPFS_BUILD}" = 1; then
if test "${SHARED_BUILD}" = 0; then
ZIPFS_BUILD=2;
printf "%s\n" "#define ZIPFS_BUILD 2" >>confdefs.h
INSTALL_LIBRARIES=install-libraries-zipfs-static
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
else
printf "%s\n" "#define ZIPFS_BUILD 1" >>confdefs.h
\
INSTALL_LIBRARIES=install-libraries-zipfs-shared
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
printf "%s\n" "yes" >&6; }
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
INSTALL_LIBRARIES=install-libraries
INSTALL_MSGS=install-msgs
fi
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
# See if declarations like FINDEX_INFO_LEVELS are
# missing from winbase.h. This is known to be
# a problem with VC++ 5.2.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
printf %s "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
if test ${tcl_cv_findex_enums+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int
main (void)
{
FINDEX_INFO_LEVELS i;
FINDEX_SEARCH_OPS j;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_findex_enums=yes
else $as_nop
tcl_cv_findex_enums=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
printf "%s\n" "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
printf "%s\n" "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h
fi
# See if the compiler supports intrinsics.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for intrinsics support in compiler" >&5
printf %s "checking for intrinsics support in compiler... " >&6; }
if test ${tcl_cv_intrinsics+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#include <intrin.h>
int
main (void)
{
__cpuidex(0,0,0);
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"
then :
tcl_cv_intrinsics=yes
else $as_nop
tcl_cv_intrinsics=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam \
conftest$ac_exeext conftest.$ac_ext
fi
{ 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 :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <wspiapi.h>
int
main (void)
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_wspiapi_h=yes
else $as_nop
tcl_cv_wspiapi_h=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_wspiapi_h" >&5
printf "%s\n" "$tcl_cv_wspiapi_h" >&6; }
if test "$tcl_cv_wspiapi_h" = "yes"; then
printf "%s\n" "#define HAVE_WSPIAPI_H 1" >>confdefs.h
fi
# See if declarations like FINDEX_INFO_LEVELS are
# missing from winbase.h. This is known to be
# a problem with VC++ 5.2.
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
printf %s "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; }
if test ${tcl_cv_findex_enums+y}
then :
printf %s "(cached) " >&6
else $as_nop
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int
main (void)
{
FINDEX_INFO_LEVELS i;
FINDEX_SEARCH_OPS j;
;
return 0;
}
_ACEOF
if ac_fn_c_try_compile "$LINENO"
then :
tcl_cv_findex_enums=yes
else $as_nop
tcl_cv_findex_enums=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5
printf "%s\n" "$tcl_cv_findex_enums" >&6; }
if test "$tcl_cv_findex_enums" = "no"; then
printf "%s\n" "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.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.
#--------------------------------------------------------------------
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
printf %s "checking for build with symbols... " >&6; }
# Check whether --enable-symbols was given.
if test ${enable_symbols+y}
then :
enableval=$enable_symbols; tcl_ok=$enableval
else $as_nop
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
printf "%s\n" "#define NDEBUG 1" >>confdefs.h
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
printf "%s\n" "no" >&6; }
printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
printf "%s\n" "yes (standard debugging)" >&6; }
fi
fi
if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h
fi
if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
printf "%s\n" "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
printf "%s\n" "#define TCL_COMPILE_STATS 1" >>confdefs.h
fi
if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
if test "$tcl_ok" = "all"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
printf "%s\n" "enabled symbols mem compile debugging" >&6; }
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
printf "%s\n" "enabled $tcl_ok debugging" >&6; }
fi
fi
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
printf %s "checking how to run the C preprocessor... " >&6; }
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
fi
if test -z "$CPP"; then
if test ${ac_cv_prog_CPP+y}
then :
printf %s "(cached) " >&6
else $as_nop
# Double quotes because $CC needs to be expanded
for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp
do
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
Syntax error
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
else $as_nop
# Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.i conftest.$ac_ext
# OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
# Broken: success on invalid input.
continue
else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
rm -f conftest.i conftest.err conftest.$ac_ext
if $ac_preproc_ok
then :
break
fi
done
ac_cv_prog_CPP=$CPP
fi
CPP=$ac_cv_prog_CPP
else
ac_cv_prog_CPP=$CPP
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
printf "%s\n" "$CPP" >&6; }
ac_preproc_ok=false
for ac_c_preproc_warn_flag in '' yes
do
# Use a header file that comes with gcc, so configuring glibc
# with a fresh cross-compiler works.
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp. "Syntax error" is here to catch this case.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <limits.h>
Syntax error
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
else $as_nop
# Broken: fails on valid input.
continue
fi
rm -f conftest.err conftest.i conftest.$ac_ext
# OK, works on sane cases. Now check whether nonexistent headers
# can be detected and how.
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <ac_nonexistent.h>
_ACEOF
if ac_fn_c_try_cpp "$LINENO"
then :
# Broken: success on invalid input.
continue
else $as_nop
# Passes both tests.
ac_preproc_ok=:
break
fi
rm -f conftest.err conftest.i conftest.$ac_ext
done
# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped.
rm -f conftest.i conftest.err conftest.$ac_ext
if $ac_preproc_ok
then :
else $as_nop
{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
See \`config.log' for more details" "$LINENO" 5; }
fi
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_c_compiler_gnu
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
printf %s "checking for grep that handles long lines and -e... " >&6; }
if test ${ac_cv_path_GREP+y}
then :
printf %s "(cached) " >&6
else $as_nop
if test -z "$GREP"; then
ac_path_GREP_found=false
# Loop through the user's path and test for each of PROGNAME-LIST
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_prog in grep ggrep
do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_GREP="$as_dir$ac_prog$ac_exec_ext"
as_fn_executable_p "$ac_path_GREP" || continue
# Check for GNU ac_path_GREP and select it if it is found.
# Check for GNU $ac_path_GREP
case `"$ac_path_GREP" --version 2>&1` in
*GNU*)
ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;;
*)
ac_count=0
printf %s 0123456789 >"conftest.in"
while :
do
cat "conftest.in" "conftest.in" >"conftest.tmp"
mv "conftest.tmp" "conftest.in"
cp "conftest.in" "conftest.nl"
printf "%s\n" 'GREP' >> "conftest.nl"
"$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break
diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
as_fn_arith $ac_count + 1 && ac_count=$as_val
if test $ac_count -gt ${ac_path_GREP_max-0}; then
# Best one so far, save it but keep looking for a better one
ac_cv_path_GREP="$ac_path_GREP"
ac_path_GREP_max=$ac_count
fi
# 10*(2^10) chars as input seems more than enough
test $ac_count -gt 10 && break
done
rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
esac
$ac_path_GREP_found && break 3
done
done
done
IFS=$as_save_IFS
if test -z "$ac_cv_path_GREP"; then
as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
fi
else
ac_cv_path_GREP=$GREP
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5
printf "%s\n" "$ac_cv_path_GREP" >&6; }
GREP="$ac_cv_path_GREP"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5
printf %s "checking for egrep... " >&6; }
if test ${ac_cv_path_EGREP+y}
then :
printf %s "(cached) " >&6
else $as_nop
if echo a | $GREP -E '(a|b)' >/dev/null 2>&1
then ac_cv_path_EGREP="$GREP -E"
else
if test -z "$EGREP"; then
ac_path_EGREP_found=false
# Loop through the user's path and test for each of PROGNAME-LIST
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
for ac_prog in egrep
do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext"
as_fn_executable_p "$ac_path_EGREP" || continue
# Check for GNU ac_path_EGREP and select it if it is found.
# Check for GNU $ac_path_EGREP
case `"$ac_path_EGREP" --version 2>&1` in
*GNU*)
ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;;
*)
ac_count=0
printf %s 0123456789 >"conftest.in"
while :
do
cat "conftest.in" "conftest.in" >"conftest.tmp"
mv "conftest.tmp" "conftest.in"
cp "conftest.in" "conftest.nl"
printf "%s\n" 'EGREP' >> "conftest.nl"
"$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
as_fn_arith $ac_count + 1 && ac_count=$as_val
if test $ac_count -gt ${ac_path_EGREP_max-0}; then
# Best one so far, save it but keep looking for a better one
ac_cv_path_EGREP="$ac_path_EGREP"
ac_path_EGREP_max=$ac_count
fi
# 10*(2^10) chars as input seems more than enough
test $ac_count -gt 10 && break
done
rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
esac
$ac_path_EGREP_found && break 3
done
done
done
IFS=$as_save_IFS
if test -z "$ac_cv_path_EGREP"; then
as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
fi
else
ac_cv_path_EGREP=$EGREP
fi
fi
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5
printf "%s\n" "$ac_cv_path_EGREP" >&6; }
EGREP="$ac_cv_path_EGREP"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5
printf %s "checking whether to embed manifest... " >&6; }
# Check whether --enable-embedded-manifest was given.
if test ${enable_embedded_manifest+y}
then :
enableval=$enable_embedded_manifest; embed_ok=$enableval
else $as_nop
embed_ok=yes
fi
VC_MANIFEST_EMBED_DLL=
VC_MANIFEST_EMBED_EXE=
result=no
if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \
-a "$GCC" != "yes" ; then
# Add the magic to embed the manifest into the dll/exe
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#if defined(_MSC_VER) && _MSC_VER >= 1400
print("manifest needed")
#endif
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "manifest needed" >/dev/null 2>&1
then :
# Could do a CHECK_PROG for mt, but should always be with MSVC8+
# Could add 'if test -f' check, but manifest should be created
# in this compiler case
# Add in a manifest argument that may be specified
# XXX Needs improvement so that the test for existence accounts
# XXX for a provided (known) manifest
VC_MANIFEST_EMBED_DLL="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;2 ; fi"
VC_MANIFEST_EMBED_EXE="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;1 ; fi"
result=yes
if test "x" != x ; then
result="yes ()"
fi
fi
rm -rf conftest*
fi
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $result" >&5
printf "%s\n" "$result" >&6; }
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
if test ${SHARED_BUILD} = 0 ; then
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
else
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${DLLSUFFIX}.a\""
fi
eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
# Adjust the defines for how the resources are built depending
# on symbols and static vs. shared.
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
RC_DEFINES=""
fi
#--------------------------------------------------------------------
# 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 ;;
|
| ︙ | ︙ | |||
5377 5378 5379 5380 5381 5382 5383 | # empty on win | < | 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 | # empty on win |
| ︙ | ︙ | |||
5458 5459 5460 5461 5462 5463 5464 |
| | | 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 | ac_config_files="$ac_config_files Makefile tclConfig.sh tclsh.exe.manifest" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. |
| ︙ | ︙ | |||
5487 5488 5489 5490 5491 5492 5493 |
# and sets the high bit in the cache file unless we assign to the vars.
(
for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
| | | | 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 |
# and sets the high bit in the cache file unless we assign to the vars.
(
for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do
eval ac_val=\$$ac_var
case $ac_val in #(
*${as_nl}*)
case $ac_var in #(
*_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
esac
case $ac_var in #(
_ | IFS | as_nl) ;; #(
BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
*) { eval $ac_var=; unset $ac_var;} ;;
esac ;;
esac
|
| ︙ | ︙ | |||
5518 5519 5520 5521 5522 5523 5524 |
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
| | | | | | | 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 |
esac |
sort
) |
sed '
/^ac_cv_env_/b end
t clear
:clear
s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/
t end
s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
:end' >>confcache
if diff "$cache_file" confcache >/dev/null 2>&1; then :; else
if test -w "$cache_file"; then
if test "x$cache_file" != "x/dev/null"; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5
printf "%s\n" "$as_me: updating cache $cache_file" >&6;}
if test ! -f "$cache_file" || test -h "$cache_file"; then
cat confcache >"$cache_file"
else
case $cache_file in #(
*/* | ?:*)
mv -f confcache "$cache_file"$$ &&
mv -f "$cache_file"$$ "$cache_file" ;; #(
*)
mv -f confcache "$cache_file" ;;
esac
fi
fi
else
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5
printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;}
fi
fi
rm -f confcache
test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
|
| ︙ | ︙ | |||
5594 5595 5596 5597 5598 5599 5600 | ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' | | | | | 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 |
ac_libobjs=
ac_ltlibobjs=
U=
for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
# 1. Remove the extension, and $U if already installed.
ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'
ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"`
# 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR
# will be set to the directory where LIBOBJS objects are built.
as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"
as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'
done
LIBOBJS=$ac_libobjs
LTLIBOBJS=$ac_ltlibobjs
: "${CONFIG_STATUS=./config.status}"
ac_write_fail=0
ac_clean_files_save=$ac_clean_files
ac_clean_files="$ac_clean_files $CONFIG_STATUS"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5
printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;}
as_write_fail=0
cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1
#! $SHELL
# Generated by $as_me.
# Run this file to recreate the current configuration.
# Compiler output produced by configure, useful for debugging
# configure, is in config.log if it exists.
|
| ︙ | ︙ | |||
5634 5635 5636 5637 5638 5639 5640 | cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh | > | > | > > > > > > > > < < < < < < < < | | < | | < < < < < < | < < < < < < < | > > | < < > | | > > > > > > > > > | > > > > | < < < < < < < > | > > > | | < < < < < < < < < < < < < < < < < < < < | | > | 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 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 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 |
cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1
## -------------------- ##
## M4sh Initialization. ##
## -------------------- ##
# Be more Bourne compatible
DUALCASE=1; export DUALCASE # for MKS sh
as_nop=:
if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
then :
emulate sh
NULLCMD=:
# Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
# is contrary to our usage. Disable this feature.
alias -g '${1+"$@"}'='"$@"'
setopt NO_GLOB_SUBST
else $as_nop
case `(set -o) 2>/dev/null` in #(
*posix*) :
set -o posix ;; #(
*) :
;;
esac
fi
# Reset variables that may have inherited troublesome values from
# the environment.
# IFS needs to be set, to space, tab, and newline, in precisely that order.
# (If _AS_PATH_WALK were called with IFS unset, it would have the
# side effect of setting IFS to empty, thus disabling word splitting.)
# Quoting is to prevent editors from complaining about space-tab.
as_nl='
'
export as_nl
IFS=" "" $as_nl"
PS1='$ '
PS2='> '
PS4='+ '
# Ensure predictable behavior from utilities with locale-dependent output.
LC_ALL=C
export LC_ALL
LANGUAGE=C
export LANGUAGE
# We cannot yet rely on "unset" to work, but we need these variables
# to be unset--not just set to an empty or harmless value--now, to
# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
# also avoids known problems related to "unset" and subshell syntax
# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
do eval test \${$as_var+y} \
&& ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
done
# Ensure that fds 0, 1, and 2 are open.
if (exec 3>&0) 2>/dev/null; then :; else exec 0</dev/null; fi
if (exec 3>&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
# The user is always right.
if ${PATH_SEPARATOR+false} :; then
PATH_SEPARATOR=:
(PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
(PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
PATH_SEPARATOR=';'
}
fi
# Find who we are. Look in the path if we contain no directory separator.
as_myself=
case $0 in #((
*[\\/]* ) as_myself=$0 ;;
*) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
case $as_dir in #(((
'') as_dir=./ ;;
*/) ;;
*) as_dir=$as_dir/ ;;
esac
test -r "$as_dir$0" && as_myself=$as_dir$0 && break
done
IFS=$as_save_IFS
;;
esac
# We did not find ourselves, most probably we were run as `sh COMMAND'
# in which case we are not to be found in the path.
if test "x$as_myself" = x; then
as_myself=$0
fi
if test ! -f "$as_myself"; then
printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
exit 1
fi
# as_fn_error STATUS ERROR [LINENO LOG_FD]
# ----------------------------------------
# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
# script with STATUS, using 1 if that was 0.
as_fn_error ()
{
as_status=$1; test $as_status -eq 0 && as_status=1
if test "$4"; then
as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
fi
printf "%s\n" "$as_me: error: $2" >&2
as_fn_exit $as_status
} # as_fn_error
# as_fn_set_status STATUS
# -----------------------
# Set $? to STATUS, without forking.
as_fn_set_status ()
{
|
| ︙ | ︙ | |||
5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
| > | > | | > | | 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 |
# ---------------
# Portably unset VAR.
as_fn_unset ()
{
{ eval $1=; unset $1;}
}
as_unset=as_fn_unset
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
# advantage of any shell optimizations that allow amortized linear growth over
# repeated appends, instead of the typical quadratic growth present in naive
# implementations.
if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
then :
eval 'as_fn_append ()
{
eval $1+=\$2
}'
else $as_nop
as_fn_append ()
{
eval $1=\$$1\$2
}
fi # as_fn_append
# as_fn_arith ARG...
# ------------------
# Perform arithmetic evaluation on the ARGs, and store the result in the
# global $as_val. Take advantage of shells that can avoid forks. The arguments
# must be portable across $(()) and expr.
if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
then :
eval 'as_fn_arith ()
{
as_val=$(( $* ))
}'
else $as_nop
as_fn_arith ()
{
as_val=`expr "$@" || test $? -eq 1`
}
fi # as_fn_arith
|
| ︙ | ︙ | |||
5855 5856 5857 5858 5859 5860 5861 | as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || | | | 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 |
as_dirname=false
fi
as_me=`$as_basename -- "$0" ||
$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
X"$0" : 'X\(//\)$' \| \
X"$0" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X/"$0" |
sed '/^.*\/\([^/][^/]*\)\/*$/{
s//\1/
q
}
/^X\/\(\/\/\)$/{
s//\1/
q
|
| ︙ | ︙ | |||
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 |
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
| > > > > > > > > > > | 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 |
# Avoid depending upon Character Ranges.
as_cr_letters='abcdefghijklmnopqrstuvwxyz'
as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
as_cr_Letters=$as_cr_letters$as_cr_LETTERS
as_cr_digits='0123456789'
as_cr_alnum=$as_cr_Letters$as_cr_digits
# Determine whether it's possible to make 'echo' print without a newline.
# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
# for compatibility with existing Makefiles.
ECHO_C= ECHO_N= ECHO_T=
case `echo -n x` in #(((((
-n*)
case `echo 'xy\c'` in
*c*) ECHO_T=' ';; # ECHO_T is single tab character.
xy) ECHO_C='\c';;
*) echo `echo ksh88 bug on AIX 6.1` > /dev/null
ECHO_T=' ';;
esac;;
*)
ECHO_N='-n';;
esac
# For backward compatibility with old third-party macros, we provide
# the shell variables $as_echo and $as_echo_n. New code should use
# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
as_echo='printf %s\n'
as_echo_n='printf %s'
rm -f conf$$ conf$$.exe conf$$.file
if test -d conf$$.dir; then
rm -f conf$$.dir/conf$$.file
else
rm -f conf$$.dir
mkdir conf$$.dir 2>/dev/null
|
| ︙ | ︙ | |||
5931 5932 5933 5934 5935 5936 5937 |
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
| | | | 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 |
case $as_dir in #(
-*) as_dir=./$as_dir;;
esac
test -d "$as_dir" || eval $as_mkdir_p || {
as_dirs=
while :; do
case $as_dir in #(
*\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
*) as_qdir=$as_dir;;
esac
as_dirs="'$as_qdir' $as_dirs"
as_dir=`$as_dirname -- "$as_dir" ||
$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$as_dir" : 'X\(//\)[^/]' \| \
X"$as_dir" : 'X\(//\)$' \| \
X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$as_dir" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
6002 6003 6004 6005 6006 6007 6008 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" | | | | 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by tcl $as_me 8.7, which was generated by GNU Autoconf 2.70. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
| ︙ | ︙ | |||
6052 6053 6054 6055 6056 6057 6058 6059 | Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 | > > | | | | | 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 | Configuration files: $config_files Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ tcl config.status 8.7 configured by $0, generated by GNU Autoconf 2.70, with options \\"\$ac_cs_config\\" Copyright (C) 2020 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF |
| ︙ | ︙ | |||
6096 6097 6098 6099 6100 6101 6102 |
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
| | | | | | 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 |
esac
case $ac_option in
# Handling of the options.
-recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
ac_cs_recheck=: ;;
--version | --versio | --versi | --vers | --ver | --ve | --v | -V )
printf "%s\n" "$ac_cs_version"; exit ;;
--config | --confi | --conf | --con | --co | --c )
printf "%s\n" "$ac_cs_config"; exit ;;
--debug | --debu | --deb | --de | --d | -d )
debug=: ;;
--file | --fil | --fi | --f )
$ac_shift
case $ac_optarg in
*\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;
'') as_fn_error $? "missing file argument" ;;
esac
as_fn_append CONFIG_FILES " '$ac_optarg'"
ac_need_defaults=false;;
--he | --h | --help | --hel | -h )
printf "%s\n" "$ac_cs_usage"; exit ;;
-q | -quiet | --quiet | --quie | --qui | --qu | --q \
| -silent | --silent | --silen | --sile | --sil | --si | --s)
ac_cs_silent=: ;;
# This is an error.
-*) as_fn_error $? "unrecognized option: \`$1'
Try \`$0 --help' for more information." ;;
|
| ︙ | ︙ | |||
6138 6139 6140 6141 6142 6143 6144 | fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift | | | < | | 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 |
fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
if \$ac_cs_recheck; then
set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
shift
\printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6
CONFIG_SHELL='$SHELL'
export CONFIG_SHELL
exec "\$@"
fi
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
exec 5>>config.log
{
echo
sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
## Running $as_me. ##
_ASBOX
printf "%s\n" "$ac_log"
} >&5
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
_ACEOF
cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Handling of arguments.
for ac_config_target in $ac_config_targets
do
case $ac_config_target in
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;
"tclsh.exe.manifest") CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac
done
# If the user did not use the arguments to specify the items to instantiate,
# then the envvar interface is used. Set only those that are not.
# We use the long form for the default assignment because of an extremely
# bizarre bug on SunOS 4.1.3.
if $ac_need_defaults; then
test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files
fi
# Have a temporary directory for convenience. Make it in the build tree
# simply because there is no reason against having it here, and in addition,
# creating and moving files from /tmp can sometimes cause problems.
# Hook for its removal unless debugging.
# Note that there is a small window in which the directory will not be cleaned:
|
| ︙ | ︙ | |||
6408 6409 6410 6411 6412 6413 6414 |
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
esac
| | | | | | | | 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 6835 6836 6837 |
test -f "$ac_f" ||
case $ac_f in
[\\/$]*) false;;
*) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;
esac ||
as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;
esac
case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac
as_fn_append ac_file_inputs " '$ac_f'"
done
# Let's still pretend it is `configure' which instantiates (i.e., don't
# use $as_me), people would be surprised to read:
# /* config.h. Generated by config.status. */
configure_input='Generated from '`
printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'
`' by configure.'
if test x"$ac_file" != x-; then
configure_input="$ac_file. $configure_input"
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5
printf "%s\n" "$as_me: creating $ac_file" >&6;}
fi
# Neutralize special characters interpreted by sed in replacement strings.
case $configure_input in #(
*\&* | *\|* | *\\* )
ac_sed_conf_input=`printf "%s\n" "$configure_input" |
sed 's/[\\\\&|]/\\\\&/g'`;; #(
*) ac_sed_conf_input=$configure_input;;
esac
case $ac_tag in
*:-:* | *:-) cat >"$ac_tmp/stdin" \
|| as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;
esac
;;
esac
ac_dir=`$as_dirname -- "$ac_file" ||
$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$ac_file" : 'X\(//\)[^/]' \| \
X"$ac_file" : 'X\(//\)$' \| \
X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||
printf "%s\n" X"$ac_file" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
|
| ︙ | ︙ | |||
6467 6468 6469 6470 6471 6472 6473 | s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) | | | | 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 | s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix |
| ︙ | ︙ | |||
6522 6523 6524 6525 6526 6527 6528 | /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) | | | | 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 |
/@docdir@/p
/@infodir@/p
/@localedir@/p
/@mandir@/p'
case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in
*datarootdir*) ac_datarootdir_seen=yes;;
*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*)
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5
printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;}
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_datarootdir_hack='
s&@datadir@&$datadir&g
s&@docdir@&$docdir&g
s&@infodir@&$infodir&g
s&@localedir@&$localedir&g
|
| ︙ | ︙ | |||
6565 6566 6567 6568 6569 6570 6571 |
eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
>$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
"$ac_tmp/out"`; test -z "$ac_out"; } &&
| | | | 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 |
eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \
>$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5
test -z "$ac_datarootdir_hack$ac_datarootdir_seen" &&
{ ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } &&
{ ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \
"$ac_tmp/out"`; test -z "$ac_out"; } &&
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined" >&5
printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir'
which seems to be undefined. Please make sure it is defined" >&2;}
rm -f "$ac_tmp/stdin"
case $ac_file in
-) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";;
*) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";;
esac \
|
| ︙ | ︙ | |||
6614 6615 6616 6617 6618 6619 6620 | $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then | | | > | 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 |
$SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
exec 5>>config.log
# Use ||, not &&, to avoid exiting from the if with $? = 1, which
# would make configure fail if this is the last instruction.
$ac_cs_success || as_fn_exit 1
fi
if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5
printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
fi
|
Changes to win/configure.ac.
1 2 3 4 5 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT([tcl],[8.7]) AC_CONFIG_SRCDIR([../generic/tcl.h]) AC_PREREQ([2.69]) # The following define is needed when building with Cygwin since newer # 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=8.7 |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
AC_PROG_CC
AC_C_INLINE
| < | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
AC_PROG_CC
AC_C_INLINE
AC_CHECK_TOOL(AR, ar)
AC_CHECK_TOOL(RANLIB, ranlib)
AC_CHECK_TOOL(RC, windres)
#--------------------------------------------------------------------
# Checks to see if the make program sets the $MAKE variable.
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | #-------------------------------------------------------------------- # Check whether --enable-time64bit was given. #-------------------------------------------------------------------- AC_MSG_CHECKING([force of 64-bit time_t]) AC_ARG_ENABLE(time64bit, | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
#--------------------------------------------------------------------
# Check whether --enable-time64bit was given.
#--------------------------------------------------------------------
AC_MSG_CHECKING([force of 64-bit time_t])
AC_ARG_ENABLE(time64bit,
AS_HELP_STRING([--enable-time64bit],
[force 64-bit time_t for 32-bit build (default: off)]),
[tcl_ok=$enableval], [tcl_ok=no])
AC_MSG_RESULT("$tcl_ok")
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 |
])
], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
| | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < | < | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
])
], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
AC_CHECK_TYPES([intptr_t, uintptr_t],,,[[
#include <stdint.h>
]])
#--------------------------------------------------------------------
# Zipfs support - Tip 430
#--------------------------------------------------------------------
AC_ARG_ENABLE(zipfs,
AS_HELP_STRING([--enable-zipfs],
[build with Zipfs support (default: on)]),
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
#
# Find a native compiler
#
AX_CC_FOR_BUILD
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
# 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,
tcl_cv_findex_enums,
| | | < | | | | | < | | | | | | | | | < | | | < < < < < < > | > > > | < < | | < < < | < < < < | < | | | 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 |
# 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,
tcl_cv_findex_enums,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
]], [[
FINDEX_INFO_LEVELS i;
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 <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,
tcl_cv_findex_enums,
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
]], [[
FINDEX_INFO_LEVELS i;
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.
#--------------------------------------------------------------------
SC_ENABLE_SYMBOLS
#--------------------------------------------------------------------
# Embed the manifest if we can determine how
#--------------------------------------------------------------------
SC_EMBED_MANIFEST
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
if test ${SHARED_BUILD} = 0 ; then
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\""
else
eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${DLLSUFFIX}.a\""
fi
eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\""
eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
#--------------------------------------------------------------------
# Adjust the defines for how the resources are built depending
# on symbols and static vs. shared.
#--------------------------------------------------------------------
if test ${SHARED_BUILD} = 0 ; then
RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
else
RC_DEFINES=""
fi
#--------------------------------------------------------------------
# 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 ;;
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_DLL_FILE) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_BIN_DIR) | < | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 | AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_DLL_FILE) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_BIN_DIR) AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) # win/tcl.m4 doesn't set (CFLAGS) AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(EXTRA_CFLAGS) |
| ︙ | ︙ | |||
518 519 520 521 522 523 524 | AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) | | > | | 473 474 475 476 477 478 479 480 481 482 483 484 485 | AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) AC_CONFIG_FILES(Makefile tclConfig.sh tclsh.exe.manifest) AC_OUTPUT dnl Local Variables: dnl mode: autoconf dnl End: |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | # Copyright (c) 2003-2008 Pat Thoyts. # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # Copyright (c) 2003-2008 Pat Thoyts. # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # # For MACRODEF, see TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) # or examine Sections 6-8 in rules.vc. # # Possible values of TARGET are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions # shell -- Just builds the shell and the core. # core -- Only builds the core [tclXX.(dll|lib)]. |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | # # NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform # SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): | | > > > > > | | | > | | | < | < | | < | 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 | # # NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform # SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=msvcrt,noembed,nothreads,pdbs,profile,static,symbols,thrdalloc,time64bit,unchecked,utfmax,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 # support. # none = Overrides all other options to nothing. # nothreads = Turns off full multithreading support (default on). # pdbs = Produce separate debug symbol files. # profile = Adds profiling hooks. Map file is assumed. # static = Builds a static library of the core instead of a # dll. The shell will be static (and large), and # have the dde and registry extensions linked inside. # symbols = Adds symbols for step debugging. # thrdalloc = Use the thread allocator (shared global free pool). # time64bit = Forces a build using 64-bit time_t for 32-bit build # (CRT library should support this). # unchecked = Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # utfmax = Forces a build using UTF-32 representation internally. # # STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 | # changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default. # # TESTPAT=<file> # Reads the tests requested to be run from this file. # | < < < < | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | # changed. $(OUT_DIR) is assumed to be # $(BINROOT)\(Release|Debug) based on if symbols are requested. # $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default. # # TESTPAT=<file> # Reads the tests requested to be run from this file. # # Examples: # c:\tcl_src\win\>nmake -f makefile.vc release # c:\tcl_src\win\>nmake -f makefile.vc test # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl # c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs # c:\tcl_src\win\>nmake -f makefile.vc release OPTS=symbols # |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 | # The rules.vc file does most of the hard work in terms of defining # the build configuration, macros, output directories etc. !include "rules.vc" # Tcl version info based on macros set up by rules.vc DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) # We need versions of various core packages to generate appropriate # file names during installation. !if [echo REM = This file is generated from makefile.vc > versions.vc] !endif !if [echo PKG_HTTP_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] | > > > > > > > > > > > > > > > > > > > > > | 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 | # The rules.vc file does most of the hard work in terms of defining # the build configuration, macros, output directories etc. !include "rules.vc" # Tcl version info based on macros set up by rules.vc DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) # The staticpkg option is not longer supported in Tcl 8.7 # though extensions may still be using it. If specified together # with "static", ignore it as that is now the default for # static build. For non-static builds, no longer supported # now (was permitted in 8.6) !if $(TCL_USE_STATIC_PACKAGES) !if $(STATIC_BUILD) !message *** NOTE: The "staticpkg" option redundant in 8.7. !else !message *** NOTE: The "staticpkg" option ignored for shared library builds. !endif !endif !if [nmakehlp -f $(OPTS) "noembed"] !message *** Option noembed specified. Tcl script library will not be appended to the binary. TCL_EMBED_SCRIPTS = 0 !else !message *** Tcl script library will be appended to the binary. TCL_EMBED_SCRIPTS = 1 !endif # We need versions of various core packages to generate appropriate # file names during installation. !if [echo REM = This file is generated from makefile.vc > versions.vc] !endif !if [echo PKG_HTTP_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] |
| ︙ | ︙ | |||
174 175 176 177 178 179 180 | !if [echo PKG_SHELL_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc] !endif !if [echo PKG_DDE_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc] !endif !if [echo PKG_REG_VER =\>> versions.vc] \ | | | < < < < < < < < < < | 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 | !if [echo PKG_SHELL_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc] !endif !if [echo PKG_DDE_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc] !endif !if [echo PKG_REG_VER =\>> versions.vc] \ && [nmakehlp -V ..\library\registry\pkgIndex.tcl "registry " >> versions.vc] !endif !include versions.vc DDEDOTVERSION = 1.4 DDEVERSION = $(DDEDOTVERSION:.=) REGDOTVERSION = 1.3 REGVERSION = $(REGDOTVERSION:.=) TCLREGLIBNAME = $(PROJECT)registry$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ |
| ︙ | ︙ | |||
431 432 433 434 435 436 437 438 439 440 441 442 443 444 | $(TMP_DIR)\tclOOStubLib.obj \ $(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 # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS # Additional Link libraries needed beyond those in rules.vc | > > | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | $(TMP_DIR)\tclOOStubLib.obj \ $(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 LIBTCLVFS = $(OUT_DIR)\libtcl.vfs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS # Additional Link libraries needed beyond those in rules.vc |
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | !endif #--------------------------------------------------------------------- # Project specific targets #--------------------------------------------------------------------- | | > | > > > > > > > > > | | | 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 | !endif #--------------------------------------------------------------------- # Project specific targets #--------------------------------------------------------------------- release: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll libtclzip: core dlls $(TCLSCRIPTZIP) all: setup $(TCLSH) $(TCLSTUBLIB) dlls libtclzip embed pkgs embed: setup $(TCLSH) $(TCLSTUBLIB) libtclzip !if $(TCL_EMBED_SCRIPTS) !if $(STATIC_BUILD) @copy /y /b "$(TCLSH)"+"$(TCLSCRIPTZIP)" "$(TCLSH)" !else @copy /y /b "$(TCLLIB)"+"$(TCLSCRIPTZIP)" "$(TCLLIB)" !endif !endif tcltest: setup $(TCLTEST) dlls install: install-binaries install-libraries install-docs install-pkgs !if $(SYMBOLS) install: install-pdbs !endif setup: default-setup test: test-core test-pkgs test-core: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.3 [list load "$(TCLDDELIB:\=/)"] package ifneeded registry 1.3.5 [list load "$(TCLREGLIB:\=/)"] << runtest: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls |
| ︙ | ︙ | |||
549 550 551 552 553 554 555 556 557 558 559 560 561 562 | $(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib $(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win32\libtommath.dll $(COPY) $(TOMMATHDIR)\win32\libtommath.dll $(OUT_DIR)\libtommath.dll $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win32\tommath.lib $(COPY) $(TOMMATHDIR)\win32\tommath.lib $(OUT_DIR)\tommath.lib !endif pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ popd \ | > > > > > > > > > > > > > > > > > | 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 |
$(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib
$(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win32\libtommath.dll
$(COPY) $(TOMMATHDIR)\win32\libtommath.dll $(OUT_DIR)\libtommath.dll
$(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win32\tommath.lib
$(COPY) $(TOMMATHDIR)\win32\tommath.lib $(OUT_DIR)\tommath.lib
!endif
$(TCLSCRIPTZIP): .PHONY
@echo Building Tcl library zip file
@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
!if ! $(STATIC_BUILD)
# 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"
!endif
@echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl"
@echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl"
@cd "$(OUT_DIR)" && $(TCLSH) 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 \
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | !else $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ $(GENERICDIR:\=/)/tclTomMath.decls $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tclOO.decls !endif | < | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | !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. #--------------------------------------------------------------------- # NOTE: you can define HHC on the command-line to override this. # nmake does not set macro values if already set on the command line. |
| ︙ | ︙ | |||
684 685 686 687 688 689 690 | @TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) @CC@ $(CC) @DEFS@ $(pkgcflags) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD @LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 | < | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | @TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) @CC@ $(CC) @DEFS@ $(pkgcflags) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD @LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 @TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib @TCL_NEEDS_EXP_FILE@ @LIBS@ $(baselibs) $(PRJ_LIBS) @prefix@ $(_INSTALLDIR) @exec_prefix@ $(BIN_INSTALL_DIR) @SHLIB_CFLAGS@ @STLIB_CFLAGS@ |
| ︙ | ︙ | |||
747 748 749 750 751 752 753 | #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \ | < > > > > > > > > > > > > | > > > > > > > > > > > > > > | | < | 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 | #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \ -Fo$@ $? $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c $(CCAPPCMD) $? # Following the lead of the autoconf based make, we define the # CFG_RUNTIME_DLLFILE flag specifically for tclZipfs and tclPkgConfig # and not as part of the global defines. Moreover, for tclZipfs, # we define only CFG_RUNTIME_DLLFILE to force use of //zipfs: # as the zip fs root. However it is defined as empty. See tclPkgConfig.obj # comments as to why. # We do not define other CFG_RUNTIME_ZIPFILE at all because # that causes the zipfs code to go looking at directories that existed # on the *build* system as opposed to the target runtime system. This # is the case even if the value is defined as an empty string. $(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c $(cc32) $(pkgcflags) \ -DCFG_RUNTIME_DLLFILE="\"\"" \ -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip \ -Fo$@ $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? # Following the lead of the autoconf based make, we define the # CFG_RUNTIME_DLLFILE and CFG_RUNTIME_ZIPFILE flags specifically for tclPkgConfig # and not as part of the global defines. These are all defined # as empty strings because they are intended to represent paths # at *runtime*, not build time. This may make sense on Unix systems # where end-user does configure and make on the target system. It # makes no sense on Windows where binary distributions may be installed # anywhere. Storing build time paths as runtime paths is misleading # at best and inefficient at worst as the code goes looking for # files and directories that do not exist. # Note: the same is true for the other CFG_RUNTIME* and CFG_INSTALL* # settings as well but they are historical and I do not want to change # them. $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ /DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DLLFILE="\"\"" \ /DCFG_RUNTIME_ZIPFILE="\"\"" \ -Fo$@ $? $(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? ### The following objects should be built using the stub interfaces $(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? |
| ︙ | ︙ | |||
903 904 905 906 907 908 909 | install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" | | | | | | | | | | | | | > > > > | | | | | > | < < < < | < < < < | | | > > > > > > | 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 | install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" @if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" @if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" @if not exist "$(MODULE_INSTALL_DIR)" \ $(MKDIR) "$(MODULE_INSTALL_DIR)" @if not exist "$(MODULE_INSTALL_DIR)\8.4" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4" @if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform" @if not exist "$(MODULE_INSTALL_DIR)\8.5" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.5" @if not exist "$(MODULE_INSTALL_DIR)\8.6" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.6" @if not exist "$(MODULE_INSTALL_DIR)\8.7" \ $(MKDIR) "$(MODULE_INSTALL_DIR)\8.7" @if not exist "$(LIB_INSTALL_DIR)\nmake" \ $(MKDIR) "$(LIB_INSTALL_DIR)\nmake" @echo Installing header files @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(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) @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" @$(CPY) "$(ROOT)\library\auto.tcl" "$(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\" @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" !if !$(TCL_EMBED_SCRIPTS) @echo Installing package cookiejar $(PKG_COOKIEJAR_VER) @$(CPY) "$(ROOT)\library\cookiejar\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\" @$(CPY) "$(ROOT)\library\cookiejar\*.gz" \ "$(SCRIPT_INSTALL_DIR)\cookiejar0.2\" @echo Installing package opt $(PKG_OPT_VER) @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ "$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ "$(MODULE_INSTALL_DIR)\8.7\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ "$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm" @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ "$(MODULE_INSTALL_DIR)\8.4\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)\8.4\platform\shell-$(PKG_SHELL_VER).tm" !endif @echo Installing $(TCLDDELIBNAME) !if !$(STATIC_BUILD) @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" !endif @echo Installing $(TCLREGLIBNAME) !if !$(STATIC_BUILD) @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\" @$(CPY) "$(ROOT)\library\registry\pkgIndex.tcl" \ "$(LIB_INSTALL_DIR)\registry$(REGDOTVERSION)\" !endif !if !$(TCL_EMBED_SCRIPTS) @echo Installing encodings @$(CPY) "$(ROOT)\library\encoding\*.enc" \ "$(SCRIPT_INSTALL_DIR)\encoding\" !endif # "emacs font-lock highlighting fix install-tzdata: !if !$(TCL_EMBED_SCRIPTS) @echo Installing time zone data @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" !endif install-msgs: !if !$(TCL_EMBED_SCRIPTS) @echo Installing message catalogs @set TCL_LIBRARY=$(ROOT:\=/)/library @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" !endif install-pdbs: @echo Installing debug symbols @$(CPY) "$(OUT_DIR)\*.pdb" "$(BIN_INSTALL_DIR)\" # "emacs font-lock highlighting fix #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 | @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) clean: default-clean clean-pkgs hose: default-hose realclean: hose # Local Variables: # mode: makefile # End: | > | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) clean: default-clean clean-pkgs hose: default-hose realclean: hose .PHONY: # Local Variables: # mode: makefile # End: |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
| | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
static int
QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
printf("%s\n", szCwd);
return 0;
}
/*
* Implements LocateDependency for a single directory. See that command
* for an explanation.
|
| ︙ | ︙ |
Changes to win/rules-ext.vc.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | !if "$(PROJECT)" == "tcl" !error The rules-ext.vc file is not intended for Tcl itself. !endif # We extract version numbers using the nmakehlp program. For now use # the local copy of nmakehlp. Once we locate Tcl, we will use that # one if it is newer. | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | !if "$(PROJECT)" == "tcl" !error The rules-ext.vc file is not intended for Tcl itself. !endif # We extract version numbers using the nmakehlp program. For now use # the local copy of nmakehlp. Once we locate Tcl, we will use that # one if it is newer. !if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] !endif # First locate the Tcl directory that we are working with. !if "$(TCLDIR)" != "" _RULESDIR = $(TCLDIR:/=\) |
| ︙ | ︙ |
Changes to win/rules.vc.
1 2 3 4 5 6 7 8 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # | | | | 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 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ !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 = 9 # 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)" == "" |
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h | | | | 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 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h !else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h !endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. !error $(MSG) |
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
# compiler version 1200. This is kept only for legacy reasons as it
# does not make sense for recent Microsoft compilers. Only used for
# output directory names.
# ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target
# NATIVE_ARCH - set to IX86 or AMD64 for the host machine
# MACHINE - same as $(ARCH) - legacy
# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed
| < < < | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
# compiler version 1200. This is kept only for legacy reasons as it
# does not make sense for recent Microsoft compilers. Only used for
# output directory names.
# ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target
# NATIVE_ARCH - set to IX86 or AMD64 for the host machine
# MACHINE - same as $(ARCH) - legacy
# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed
cc32 = $(CC) # built-in default.
link32 = link
lib32 = lib
rc32 = $(RC) # built-in default.
#----------------------------------------------------------------
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 | # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif | < < < < | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 | # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is # in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version # otherwise. In the latter case, they would also be using their own # rules.vc. Note that older versions of Tcl do not install nmakehlp.c # or rules.vc. # |
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
| | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
!else # !$(TCLINSTALL)
!if exist("$(_TCLDIR)\win\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c
!endif
!endif # $(TCLINSTALL)
!endif # !$(DOING_TCL)
!endif # NMAKEHLPC
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 662 | # If compiler has enabled link time optimization, linker must too with -ltcg !ifdef CC_GL_OPT_ENABLED !if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -ltcg !endif !endif ######################################################################## | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | > | 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 |
# If compiler has enabled link time optimization, linker must too with -ltcg
!ifdef CC_GL_OPT_ENABLED
!if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)]
LINKERFLAGS = $(LINKERFLAGS) -ltcg
!endif
!endif
################################################################
# 6. Extract various version numbers from headers
# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h
# respectively. For extensions, versions are extracted from the
# configure.in or configure.ac from the TEA configuration if it
# exists, and unset otherwise.
# Sets the following macros:
# TCL_MAJOR_VERSION
# TCL_MINOR_VERSION
# TCL_RELEASE_SERIAL
# TCL_PATCH_LEVEL
# TCL_PATCH_LETTER
# TCL_VERSION
# TK_MAJOR_VERSION
# TK_MINOR_VERSION
# TK_RELEASE_SERIAL
# TK_PATCH_LEVEL
# TK_PATCH_LETTER
# TK_VERSION
# DOTVERSION - set as (for example) 2.5
# VERSION - set as (for example 25)
#--------------------------------------------------------------
!if [echo REM = This file is generated from rules.vc > versions.vc]
!endif
!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \
&& [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc]
!endif
!if [echo TCL_MINOR_VERSION = \>> versions.vc] \
&& [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc]
!endif
!if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \
&& [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc]
!endif
!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \
&& [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc]
!endif
!if defined(_TK_H)
!if [echo TK_MAJOR_VERSION = \>> versions.vc] \
&& [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc]
!endif
!if [echo TK_MINOR_VERSION = \>> versions.vc] \
&& [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc]
!endif
!if [echo TK_RELEASE_SERIAL = \>> versions.vc] \
&& [nmakehlp -V "$(_TK_H)" TK_RELEASE_SERIAL >> versions.vc]
!endif
!if [echo TK_PATCH_LEVEL = \>> versions.vc] \
&& [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc]
!endif
!endif # _TK_H
!include versions.vc
TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
!if [nmakehlp -f $(TCL_PATCH_LEVEL) "a"]
TCL_PATCH_LETTER = a
!elseif [nmakehlp -f $(TCL_PATCH_LEVEL) "b"]
TCL_PATCH_LETTER = b
!else
TCL_PATCH_LETTER = .
!endif
!if defined(_TK_H)
TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION)
TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
!if [nmakehlp -f $(TK_PATCH_LEVEL) "a"]
TK_PATCH_LETTER = a
!elseif [nmakehlp -f $(TK_PATCH_LEVEL) "b"]
TK_PATCH_LETTER = b
!else
TK_PATCH_LETTER = .
!endif
!endif
# Set DOTVERSION and VERSION
!if $(DOING_TCL)
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_VERSION)
!elseif $(DOING_TK)
DOTVERSION = $(TK_DOTVERSION)
VERSION = $(TK_VERSION)
!else # Doing a non-Tk extension
# If parent makefile has not defined DOTVERSION, try to get it from TEA
# first from a configure.in file, and then from configure.ac
!ifndef DOTVERSION
!if [echo DOTVERSION = \> versions.vc] \
|| [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc]
!if [echo DOTVERSION = \> versions.vc] \
|| [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc]
!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc.
!endif
!endif
!include versions.vc
!endif # DOTVERSION
VERSION = $(DOTVERSION:.=)
!endif # $(DOING_TCL) ... etc.
# Windows RC files have 3 version components. Ensure this irrespective
# of how many components the package has specified. Basically, ensure
# minimum 4 components by appending 4 0's and then pick out the first 4.
# Also take care of the fact that DOTVERSION may have "a" or "b" instead
# of "." separating the version components.
DOTSEPARATED=$(DOTVERSION:a=.)
DOTSEPARATED=$(DOTSEPARATED:b=.)
!if [echo RCCOMMAVERSION = \> versions.vc] \
|| [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc]
!error *** Could not generate RCCOMMAVERSION ***
!endif
!include versions.vc
########################################################################
# 7. Parse the OPTS macro to work out the requested build configuration.
# Based on this, we will construct the actual switches to be passed to the
# compiler and linker using the macros defined in the previous section.
# The following macros are defined by this section based on OPTS
# STATIC_BUILD - 0 -> Tcl is to be built as a shared library
# 1 -> build as a static library and shell
# TCL_THREADS - legacy but always 1 on Windows since winsock requires it.
# DEBUG - 1 -> debug build, 0 -> release builds
# SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's
# PROFILE - 1 -> generate profiling info, 0 -> no profiling
# PGO - 1 -> profile based optimization, 0 -> no
# MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build
# 0 -> link to static C runtime for static Tcl build.
# Does not impact shared Tcl builds (STATIC_BUILD == 0)
# Default: 1 for Tcl 8.7 and up, 0 otherwise.
# TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions
# in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does
# not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7.
# USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation.
# 0 -> Use the non-thread allocator.
# UNCHECKED - 1 -> when doing a debug build with symbols, use the release
# C runtime, 0 -> use the debug C runtime.
# USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking
# CONFIG_CHECK - 1 -> check current build configuration against Tcl
# configuration (ignored for Tcl itself)
# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build
# (CRT library should support this, not needed for Tcl 9.x)
# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally.
# (Not needed for Tcl 9.x)
# Further, LINKERFLAGS are modified based on above.
# Default values for all the above
STATIC_BUILD = 0
TCL_THREADS = 1
DEBUG = 0
SYMBOLS = 0
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt | < | < < < < < < < > > | 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 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 && $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !if [nmakehlp -f $(OPTS) "utfmax"] !message *** Force allowing 4-byte UTF-8 sequences internally TCL_UTF_MAX = 4 !endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 |
| ︙ | ︙ | |||
844 845 846 847 848 849 850 | MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !endif ################################################################ | | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 | MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !endif ################################################################ # 8. Parse the STATS macro to configure code instrumentation # The following macros are set by this section: # TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation # 0 -> disables # TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging # 0 -> disables # Default both are off |
| ︙ | ︙ | |||
874 875 876 877 878 879 880 | !else TCL_COMPILE_DEBUG = 0 !endif !endif #################################################################### | | | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 | !else TCL_COMPILE_DEBUG = 0 !endif !endif #################################################################### # 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level # TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions # 0 -> enable deprecated functions # Defaults - Permit deprecated functions and warning level 3 TCL_NO_DEPRECATED = 0 |
| ︙ | ︙ | |||
906 907 908 909 910 911 912 | !if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] !message *** Doing 64bit portability warnings WARNINGS = $(WARNINGS) -Wp64 !endif !endif | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 | !if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] !message *** Doing 64bit portability warnings WARNINGS = $(WARNINGS) -Wp64 !endif !endif ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # |
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 | !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif | | | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 | !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif !if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) |
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 1102 | !error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) !endif !include nmakehlp.out # The name of the stubs library for the project being built STUBPREFIX = $(PROJECT)stub # Set up paths to various Tcl executables and libraries needed by extensions | > > | > > > > > > > > > > > > > | | 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 | !error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) !endif !include nmakehlp.out # The name of the stubs library for the project being built 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 !if "$(TCL_PATCH_LETTER)" == "." TCLSCRIPTZIPNAME = libtcl_$(TCL_MAJOR_VERSION)_$(TCL_MINOR_VERSION)_$(TCL_RELEASE_SERIAL).zip !else TCLSCRIPTZIPNAME = libtcl_$(TCL_MAJOR_VERSION)_$(TCL_MINOR_VERSION)_$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip !endif !if "$(TK_PATCH_LETTER)" == "." TKSCRIPTZIPNAME = libtk_$(TK_MAJOR_VERSION)_$(TK_MINOR_VERSION)_$(TK_RELEASE_SERIAL).zip !else TKSCRIPTZIPNAME = libtk_$(TK_MAJOR_VERSION)_$(TK_MINOR_VERSION)_$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip !endif !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)\$(TCLSCRIPTZIPNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe |
| ︙ | ︙ | |||
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 |
# "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
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))
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "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
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif # TCLINSTALL
tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)"
| > > | 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 |
# "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\$(TCLSCRIPTZIPNAME)
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))
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "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)\$(TCLSCRIPTZIPNAME)
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif # TCLINSTALL
tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)"
|
| ︙ | ︙ | |||
1181 1182 1183 1184 1185 1186 1187 | TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) | | > > > > > > > | 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 |
TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib
!if $(DOING_TK)
WISH = $(OUT_DIR)\$(WISHNAME)
TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME)
TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME)
TKLIB = $(OUT_DIR)\$(TKLIBNAME)
TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME)
!else # effectively NEED_TK
!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\$(TKSCRIPTZIPNAME)
!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)\$(TKSCRIPTZIPNAME)
!endif # TKINSTALL
tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)"
!endif # $(DOING_TK)
!endif # $(DOING_TK) || $(NEED_TK)
# Various output paths
PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk | > | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk |
| ︙ | ︙ | |||
1292 1293 1294 1295 1296 1297 1298 | # lflags - complete linker switches (subsumes ldebug) except subsystem type # dlllflags - complete linker switches to build DLLs (subsumes lflags) # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed | | | | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 | # lflags - complete linker switches (subsumes ldebug) except subsystem type # dlllflags - complete linker switches to build DLLs (subsumes lflags) # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed OPTDEFINES = /DSTDC_HEADERS !if $(VCVERSION) > 1600 OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 !endif !if $(VCVERSION) >= 1800 OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 !endif |
| ︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 | !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs | | | 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 | !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS |
| ︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 |
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1
!endif
!if "$(_USE_64BIT_TIME_T)" == "1"
OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1
!endif
!if "$(TCL_UTF_MAX)" == "4"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4
!endif
# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS = /D_ATL_XP_TARGETING
# 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)\"" \
| > > | 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 |
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
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
!if "$(TCL_UTF_MAX)" == "4"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4
!endif
# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS = /D_ATL_XP_TARGETING
!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)\"" \
|
| ︙ | ︙ | |||
1486 1487 1488 1489 1490 1491 1492 | ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif | < < < < < < < < < < < < | 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 | ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows # Libraries that are required for every image. # Extensions should define any additional libraries with $(PRJ_LIBS) winlibs = kernel32.lib advapi32.lib |
| ︙ | ︙ | |||
1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 |
@$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
default-install-pdbs:
@echo Installing PDBs to '$(LIB_INSTALL_DIR)'
@if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
@$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\"
default-install-docs-html:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
@if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
@if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)"
default-install-docs-n:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
| > > | 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
@$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
default-install-pdbs:
@echo Installing PDBs to '$(LIB_INSTALL_DIR)'
@if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)"
@$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\"
# "emacs font-lock highlighting fix
default-install-docs-html:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
@if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
@if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)"
default-install-docs-n:
@echo Installing documentation files to '$(DOC_INSTALL_DIR)'
|
| ︙ | ︙ | |||
1667 1668 1669 1670 1671 1672 1673 |
@if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
$(DEBUGGER) $(TCLSH)
# Generation of Windows version resource
!ifdef RCFILE
# Note: don't use $** in below rule because there may be other dependencies
| | | 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
@if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
$(DEBUGGER) $(TCLSH)
# Generation of Windows version resource
!ifdef RCFILE
# Note: don't use $** in below rule because there may be other dependencies
# and only the "main" rc must be passed to the resource compiler
$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc
$(RESCMD) $(RCDIR)\$(PROJECT).rc
!else
# If parent makefile has not defined a resource definition file,
# we will generate one from standard template.
|
| ︙ | ︙ | |||
1721 1722 1723 1724 1725 1726 1727 | !ifndef DISABLE_IMPLICIT_RULES DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and | | | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 |
!ifndef DISABLE_IMPLICIT_RULES
DISABLE_IMPLICIT_RULES = 0
!endif
!if !$(DISABLE_IMPLICIT_RULES)
# Implicit rule definitions - only for building library objects. For stubs and
# main application, the makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 | !endif ################################################################ # 14. Sanity check selected options against Tcl build options # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. | | | | | | | 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 |
!endif
################################################################
# 14. Sanity check selected options against Tcl build options
# When building an extension, certain configuration options should
# match the ones used when Tcl was built. Here we check and
# warn on a mismatch.
!if !$(DOING_TCL)
!if $(TCLINSTALL) # Building against an installed Tcl
!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake")
TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake"
!endif
!else # !$(TCLINSTALL) - building against Tcl source
!if exist("$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake")
TCLNMAKECONFIG = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake"
!endif
!endif # TCLINSTALL
!if $(CONFIG_CHECK)
!ifdef TCLNMAKECONFIG
!include $(TCLNMAKECONFIG)
!if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)"
!error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)).
!endif
!if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC)
!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)).
!endif
!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG)
!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)).
!endif
!endif
!endif # TCLNMAKECONFIG
!endif # !$(DOING_TCL)
#----------------------------------------------------------
# Display stats being used.
#----------------------------------------------------------
!if !$(DOING_TCL)
|
| ︙ | ︙ |
Changes to win/targets.vc.
1 2 3 4 5 6 | #------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) $(PRJSTUBLIB): $(PRJ_STUBOBJS) $(LIBCMD) $** |
| ︙ | ︙ |
Changes to win/tcl.dsp.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | !IF "$(CFG)" == "tcl - Win32 Release" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Dynamic" | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | !IF "$(CFG)" == "tcl - Win32 Release" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" # PROP BASE Target_File "Release\tclsh87.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release\tcl_Dynamic" # PROP Cmd_Line "nmake -nologo -f makefile.vc MSVCDIR=IDE" # PROP Rebuild_Opt "clean release" # PROP Target_File "Release\tclsh87t.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Debug" |
| ︙ | ︙ | |||
344 345 346 347 348 349 350 | # End Source File # Begin Source File SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | # End Source File # Begin Source File SOURCE=..\doc\CrtObjCmd.3 # End Source File # Begin Source File SOURCE=..\doc\CrtAlias.3 # End Source File # Begin Source File SOURCE=..\doc\CrtTimerHdlr.3 # End Source File # Begin Source File |
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 | SOURCE=.\rmd.bat # End Source File # Begin Source File SOURCE=.\rules.vc # End Source File | < < < < | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 | SOURCE=.\rmd.bat # End Source File # Begin Source File SOURCE=.\rules.vc # End Source File # Begin Source File SOURCE=.\tcl.m4 # End Source File # Begin Source File SOURCE=.\tcl.rc |
| ︙ | ︙ |
Deleted win/tcl.hpj.in.
|
| < < < < < < < < < < < < < < < < < < < |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
# we reset no_tcl in case something fails here
no_tcl=true
AC_ARG_WITH(tcl,
| | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
# we reset no_tcl in case something fails here
no_tcl=true
AC_ARG_WITH(tcl,
AS_HELP_STRING([--with-tcl],
[directory containing tcl configuration (tclConfig.sh)]),
[with_tclconfig="${withval}"])
AC_MSG_CHECKING([for Tcl configuration])
AC_CACHE_VAL(ac_cv_c_tclconfig,[
# First check to see if --with-tcl was specified.
if test x"${with_tclconfig}" != x ; then
case "${with_tclconfig}" in
*/tclConfig.sh )
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
# we reset no_tk in case something fails here
no_tk=true
AC_ARG_WITH(tk,
| | | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 |
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
# we reset no_tk in case something fails here
no_tk=true
AC_ARG_WITH(tk,
AS_HELP_STRING([--with-tk],
[directory containing tk configuration (tkConfig.sh)]),
[with_tkconfig="${withval}"])
AC_MSG_CHECKING([for Tk configuration])
AC_CACHE_VAL(ac_cv_c_tkconfig,[
# First check to see if --with-tkconfig was specified.
if test x"${with_tkconfig}" != x ; then
case "${with_tkconfig}" in
*/tkConfig.sh )
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
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
| < < < < < < < < < | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
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)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
[ --enable-shared build and link with shared libraries (default: on)],
[tcl_ok=$enableval], [tcl_ok=yes])
| < < < < < < < < | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 |
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
[ --enable-shared build and link with shared libraries (default: on)],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "$tcl_ok" = "yes" ; then
AC_MSG_RESULT([shared])
SHARED_BUILD=1
else
AC_MSG_RESULT([static])
SHARED_BUILD=0
AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?])
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 | # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false | < < < | 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 |
# --enable-symbols
#
# Defines the following vars:
# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
AC_MSG_RESULT([no])
AC_DEFINE(TCL_CFG_OPTIMIZED)
else
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
if test "$tcl_ok" = "yes"; then
AC_MSG_RESULT([yes (standard debugging)])
fi
fi
AC_SUBST(CFLAGS_DEFAULT)
AC_SUBST(LDFLAGS_DEFAULT)
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 |
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
AC_CACHE_CHECK(for working -municode linker flag,
ac_cv_municode,
AC_TRY_LINK([
#include <windows.h>
int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
| < | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain"
AC_CACHE_CHECK(for working -municode linker flag,
ac_cv_municode,
AC_TRY_LINK([
#include <windows.h>
int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;}
], [],
ac_cv_municode=yes,
ac_cv_municode=no)
)
CFLAGS=$hold_cflags
if test "$ac_cv_municode" = "yes" ; then
extra_ldflags="$extra_ldflags -municode"
else
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
LIBPREFIX="lib"
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | | | | 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 |
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}"
fi
# Link with gcc since ld does not link to default libs like
# -luser32 and -lmsvcrt by default.
SHLIB_LD='${CC} -shared'
SHLIB_LD_LIBS='${LIBS}'
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.dll.a,\[$]@)"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".a"
LIBFLAGSUFFIX=""
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith -finput-charset=UTF-8"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers -Wdeclaration-after-statement"
;;
esac
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \[$]@"
CC_EXENAME="-o \[$]@"
|
| ︙ | ︙ | |||
746 747 748 749 750 751 752 |
esac
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
LIBRARIES="\${STATIC_LIBRARIES}"
| | | | | | | 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 |
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"
;;
*)
;;
esac
fi
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX=".dll"
LIBSUFFIX=".lib"
LIBFLAGSUFFIX=""
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
|
| ︙ | ︙ | |||
923 924 925 926 927 928 929 | #include <windows.h> #undef WIN32_LEAN_AND_MEAN ], [ CHAR c; SHORT s; LONG l; ], | | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 | #include <windows.h> #undef WIN32_LEAN_AND_MEAN ], [ CHAR c; SHORT s; LONG l; ], tcl_cv_winnt_ignore_void=yes, tcl_cv_winnt_ignore_void=no) ) if test "$tcl_cv_winnt_ignore_void" = "yes" ; then AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1, [Defined when cygwin/mingw ignores VOID define in winnt.h]) fi AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],) |
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 |
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
| | | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 |
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${EXEEXT}
AC_MSG_RESULT($BUILD_TCLSH)
AC_SUBST(BUILD_TCLSH)
])
#--------------------------------------------------------------------
# SC_TCL_CFG_ENCODING TIP #59
#
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval})
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}")
else
| < | | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval})
if test x"${with_tcencoding}" != x ; then
AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}")
else
AC_DEFINE(TCL_CFGVAL_ENCODING,"utf-8")
fi
])
#--------------------------------------------------------------------
# SC_EMBED_MANIFEST
#
# Figure out if we can embed the manifest where necessary
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 |
# VC_MANIFEST_EMBED_EXE
#
#--------------------------------------------------------------------
AC_DEFUN([SC_EMBED_MANIFEST], [
AC_MSG_CHECKING(whether to embed manifest)
AC_ARG_ENABLE(embedded-manifest,
| | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
# VC_MANIFEST_EMBED_EXE
#
#--------------------------------------------------------------------
AC_DEFUN([SC_EMBED_MANIFEST], [
AC_MSG_CHECKING(whether to embed manifest)
AC_ARG_ENABLE(embedded-manifest,
AS_HELP_STRING([--enable-embedded-manifest],
[embed manifest if possible (default: yes)]),
[embed_ok=$enableval], [embed_ok=yes])
VC_MANIFEST_EMBED_DLL=
VC_MANIFEST_EMBED_EXE=
result=no
if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \
|
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | #include <tchar.h> #ifdef TCL_TEST extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #include <tchar.h> #ifdef TCL_TEST extern Tcl_PackageInitProc Tcltest_Init; extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(STATIC_BUILD) extern Tcl_PackageInitProc Registry_Init; extern Tcl_PackageInitProc Dde_Init; extern Tcl_PackageInitProc Dde_SafeInit; #endif #if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
| | > < > > | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
char **argv1)
{
TCHAR **argv;
TCHAR *p;
#else
int
_tmain(
int argc, /* Number of command-line arguments. */
TCHAR *argv[]) /* Values of command-line arguments. */
{
TCHAR *p;
#endif
/*
* Set up the default locale to be standard "C" locale so parsing is
* performed correctly.
*/
setlocale(LC_ALL, "C");
#ifdef TCL_BROKEN_MAINARGS
/*
* Get our args from the c-runtime. Ignore command line.
*/
(void)argv1;
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
if ((Tcl_Init)(interp) == TCL_ERROR) {
return TCL_ERROR;
}
| | | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
if ((Tcl_Init)(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#if defined(STATIC_BUILD)
if (Registry_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Registry", Registry_Init, NULL);
if (Dde_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Dde", Dde_Init, Dde_SafeInit);
#endif
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit);
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
}
}
/* Make sure we don't call ckalloc through the (not yet initialized) stub table */
# undef Tcl_Alloc
# undef Tcl_DbCkalloc
| | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
}
}
/* Make sure we don't call ckalloc through the (not yet initialized) stub table */
# undef Tcl_Alloc
# undef Tcl_DbCkalloc
argSpace = (TCHAR *)ckalloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
argv = (TCHAR **) argSpace;
argSpace += size * (sizeof(char *)/sizeof(TCHAR));
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
|
| ︙ | ︙ |
Changes to win/tclConfig.sh.in.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' | | | > | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # C compiler to use for compilation. TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' # TCL_DBGX used to be used to distinguish debug vs. non-debug builds. # This was a righteous pain so the core doesn't do that any more. # DEPRECATED, will be removed in Tcl 9! TCL_DBGX='' # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' # Default linker flags used in an optimized and debuggable build, respectively. TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' |
| ︙ | ︙ |
Changes to win/tclWin32Dll.c.
1 2 3 4 5 6 | /* * tclWin32Dll.c -- * * This file contains the DLL entry point and other low-level bit bashing * code that needs inline assembly. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclWin32Dll.c -- * * This file contains the DLL entry point and other low-level bit bashing * code that needs inline assembly. * * Copyright © 1995-1996 Sun Microsystems, Inc. * 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_INTRIN_H) |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
| | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
LPVOID reserved)
{
return DllMain(hInst, reason, reserved);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllMain(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllMain(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
TCL_UNUSED(LPVOID))
{
switch (reason) {
case DLL_PROCESS_ATTACH:
DisableThreadLibraryCalls(hInst);
TclWinInit(hInst);
return TRUE;
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
| | | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target);
dlPtr2->driveLetter = (char) drive[0];
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
}
}
}
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
}
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
| | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
}
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep((void *)mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" | | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" : /* No outputs */ : [index] "m" (index), [rptr] "m" (regsPtr) : |
| ︙ | ︙ | |||
567 568 569 570 571 572 573 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | | 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 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Do the CPUID instruction, and save the results in the 'regsPtr' * area. */ "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" /* * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ "movl %%fs:0, %%edx" "\n\t" |
| ︙ | ︙ | |||
614 615 616 617 618 619 620 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ |
Changes to win/tclWinChan.c.
1 2 3 4 5 6 | /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command pipes and * TCP sockets. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * 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" |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * Static routines for this file: */ static int FileBlockProc(ClientData instanceData, int mode); static void FileChannelExitHandler(ClientData clientData); static void FileCheckProc(ClientData clientData, int flags); static int FileCloseProc(ClientData instanceData, | | > > | > > > > | | 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 |
* Static routines for this file:
*/
static int FileBlockProc(ClientData instanceData, int mode);
static void FileChannelExitHandler(ClientData clientData);
static void FileCheckProc(ClientData clientData, int flags);
static int FileCloseProc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int FileEventProc(Tcl_Event *evPtr, int flags);
static int FileGetHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static ThreadSpecificData *FileInit(void);
static int FileInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(ClientData instanceData,
const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int FileSeekProc(ClientData instanceData, long offset,
int mode, int *errorCode);
#endif
static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
static void FileSetupProc(ClientData clientData, int flags);
static void FileWatchProc(ClientData instanceData, int mask);
static void FileThreadActionProc(ClientData instanceData,
int action);
static int FileTruncateProc(ClientData instanceData,
Tcl_WideInt length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
/*
* This structure describes the channel type structure for file based IO.
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
#else
NULL,
#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Set up the notifier to watch the channel. */
FileGetHandleProc, /* Get an OS handle from channel. */
FileCloseProc, /* close2proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* Wide seek proc. */
FileThreadActionProc, /* Thread action proc. */
FileTruncateProc /* Truncate proc. */
};
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 | * Destroys the communication window. * *---------------------------------------------------------------------- */ static void FileChannelExitHandler( | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
* Destroys the communication window.
*
*----------------------------------------------------------------------
*/
static void
FileChannelExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void FileSetupProc( | | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
FileSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 | * May queue an event. * *---------------------------------------------------------------------- */ static void FileCheckProc( | | | | 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 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
FileCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileEvent *evPtr;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
/*
* Queue events for any ready files that don't already have events queued
* (caused by persistent states that won't generate WinSock events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) {
SET_FLAG(infoPtr->flags, FILE_PENDING);
evPtr = (FileEvent *)ckalloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
static int
FileBlockProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
static int
FileBlockProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
* hence we have to emulate the behavior. This is done in the input
* function by checking against a bit in the state. We set or unset the
* bit here to cause the input function to emulate the correct behavior.
*/
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
| | > | > > > > | 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 |
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
FileInfo *fileInfoPtr = (FileInfo *)instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Remove the file from the watch list.
*/
FileWatchProc(instanceData, 0);
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 | * * Side effects: * Moves the location at which the channel will be accessed in future * operations. * *---------------------------------------------------------------------- */ | | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
*
* Side effects:
* Moves the location at which the channel will be accessed in future
* operations.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
ClientData instanceData, /* File state. */
long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
DWORD moveMethod;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
return (int) newPos;
}
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
| > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
return (int) newPos;
}
#endif
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
static Tcl_WideInt
FileWideSeekProc(
ClientData instanceData, /* File state. */
Tcl_WideInt offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
| | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
static Tcl_WideInt
FileWideSeekProc(
ClientData instanceData, /* File state. */
Tcl_WideInt offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD moveMethod;
LONG newPos, newPosHigh;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
*/
static int
FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
| | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
*/
static int
FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
/*
* Save where we were...
*/
oldPosHigh = 0;
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
static int
FileInputProc(
ClientData instanceData, /* File state. */
char *buf, /* Where to store data read. */
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
static int
FileInputProc(
ClientData instanceData, /* File state. */
char *buf, /* Where to store data read. */
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesRead;
*errorCode = 0;
/*
* TODO: This comment appears to be out of date. We *do* have a console
* driver, over in tclWinConsole.c. After some Windows developer confirms,
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
static int
FileOutputProc(
ClientData instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
| | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
static int
FileOutputProc(
ClientData instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesWritten;
*errorCode = 0;
/*
* If we are writing to a file that was opened with O_APPEND, we need to
* seek to the end of the file before writing the current buffer.
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
static void
FileWatchProc(
ClientData instanceData, /* File state. */
int mask) /* What events to watch for; OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
| | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
static void
FileWatchProc(
ClientData instanceData, /* File state. */
int mask) /* What events to watch for; OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
* Since the file is always ready for events, we set the block time to
* zero so we will poll.
*/
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
static int
FileGetHandleProc(
ClientData instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
| | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
static int
FileGetHandleProc(
ClientData instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
const WCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
| | | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
const WCHAR *nativeName;
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;
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
| | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS
: ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
|
| ︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
| | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = (FileInfo *)ckalloc(sizeof(FileInfo));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
*/
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
static void
FileThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 |
static void
FileThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileInfo *infoPtr = (FileInfo *)instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
} else {
FileInfo **nextPtrPtr;
int removed = 0;
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
1 2 3 4 5 6 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the * "console" channel driver. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the * "console" channel driver. * * Copyright © 1999 Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" |
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | * Declarations for functions used only in this file. */ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | * Declarations for functions used only in this file. */ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int ConsoleGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); |
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
ConsoleSetOptionProc, /* Set option proc. */
ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
ConsoleCloseProc, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
NULL, /* Wide seek proc. */
ConsoleThreadActionProc, /* Thread action proc. */
NULL /* Truncation proc. */
};
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 | * Removes the console event source. * *---------------------------------------------------------------------- */ static void ConsoleExitHandler( | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
* Removes the console event source.
*
*----------------------------------------------------------------------
*/
static void
ConsoleExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&consoleMutex);
initialized = 0;
Tcl_MutexUnlock(&consoleMutex);
}
/*
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void ConsoleSetupProc( | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
ConsoleSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 | * May queue an event. * *---------------------------------------------------------------------- */ static void ConsoleCheckProc( | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
ConsoleCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent));
infoPtr->flags |= CONSOLE_PENDING;
evPtr->header.proc = ConsoleEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 |
static int
ConsoleBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
| | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
static int
ConsoleBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
* nonblocking, hence we have to emulate the behavior. This is done in the
* input function by checking against a bit in the state. We set or unset
* the bit here to cause the input function to emulate the correct
* behavior.
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
| | > | > > > > | 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 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData;
int errorCode = 0;
ConsoleInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Clean up the background thread if necessary. Note that this must be
* done before we can close the file, since the thread may be blocking
* trying to read from the console.
*/
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
ConsoleInputProc(
ClientData instanceData, /* Console 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. */
{
| | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
ConsoleInputProc(
ClientData instanceData, /* Console 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. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
DWORD count, bytesRead = 0;
int result;
*errorCode = 0;
/*
* Synchronize with the reader thread.
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
| | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
ConsoleThreadInfo *threadInfo = &infoPtr->writer;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI)
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
| | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(threadInfo->readyEvent);
TclPipeThreadSignal(&threadInfo->TI);
bytesWritten = toWrite;
} else {
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 |
ConsoleWatchProc(
ClientData instanceData, /* Console state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
ConsoleWatchProc(
ClientData instanceData, /* Console state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int oldMask = infoPtr->watchMask;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
| | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
*handlePtr = infoPtr->handle;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1016 1017 1018 1019 1020 1021 1022 |
static int
WaitForRead(
ConsoleInfo *infoPtr, /* Console state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
| | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
static int
WaitForRead(
ConsoleInfo *infoPtr, /* Console state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
HANDLE *handle = (HANDLE *)infoPtr->handle;
ConsoleThreadInfo *threadInfo = &infoPtr->reader;
INPUT_RECORD input;
while (1) {
/*
* Synchronize with the reader thread.
*/
|
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 |
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
| | | 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 |
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->reader;
}
/*
* Look for data on the console, but first ignore any events that are
* not KEY_EVENTs.
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
| | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 |
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->writer;
}
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
/*
|
| ︙ | ︙ | |||
1317 1318 1319 1320 1321 1322 1323 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
| | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
|
| ︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 |
*/
static void
ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
| | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
*/
static void
ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* We do not access firstConsolePtr in the thread structures. This is not
* for all serials managed by the thread, but only those we are watching.
* Removal of the filevent handlers before transfer thus takes care of
* this structure.
*/
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
| | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
/*
* Option -inputmode normal|password|raw
*/
|
| ︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 |
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
char buf[TCL_INTEGER_SPACE];
if (optionName == NULL) {
len = 0;
} else {
|
| ︙ | ︙ |
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
| | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
| CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
ddeInstance = 0;
}
}
Tcl_MutexUnlock(&ddeMutex);
}
|
| ︙ | ︙ |
Changes to win/tclWinError.c.
1 2 3 4 5 6 | /* * tclWinError.c -- * * This file contains code for converting from Win32 errors to errno * errors. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinError.c -- * * This file contains code for converting from Win32 errors to errno * errors. * * Copyright © 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. */ #include "tclInt.h" /* |
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
OutputDebugStringW(msgString);
} else {
if (!isatty(fileno(stderr))) {
| | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
OutputDebugStringW(msgString);
} else {
if (!isatty(fileno(stderr))) {
fprintf(stderr, "\xEF\xBB\xBF");
}
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
}
# if defined(__GNUC__)
__builtin_trap();
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
1 2 3 4 5 6 | /* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. * * Copyright © 1996-1998 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" |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoRenameFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
(const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
const WCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
const WCHAR *nativeDst) /* New pathname for file or directory
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
| | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeDst, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoCopyFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
(const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
const WCHAR *nativeSrc, /* Pathname of file to be copied (native). */
const WCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
631 632 633 634 635 636 637 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
| | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr != 0xFFFFFFFF) {
if (dstAttr == 0xFFFFFFFF) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
| | | | 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 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
const WCHAR *path = (const WCHAR *)nativePath;
/*
* The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
* "". Avoid passing these values.
*/
if (path == NULL || path[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(path, 0) == 0) {
return TCL_OK;
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
| | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
return DoCreateDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const WCHAR *nativePath) /* Pathname of directory to create (native). */
{
if (CreateDirectoryW(nativePath, NULL) == 0) {
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
return TCL_ERROR;
}
Tcl_DStringInit(&native);
Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
| | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
return TCL_ERROR;
}
Tcl_DStringInit(&native);
Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
if (Tcl_DStringLength(&ds) > 0) {
if (normPtr != NULL &&
!strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
*errorPtr = pathPtr;
|
| ︙ | ︙ | |||
1054 1055 1056 1057 1058 1059 1060 |
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
| | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
if (attr != 0xFFFFFFFF) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
|
| ︙ | ︙ | |||
1191 1192 1193 1194 1195 1196 1197 |
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAW data;
nativeErrfile = NULL;
result = TCL_OK;
| | | | 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAW data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0;
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributesW(nativeSource);
if (sourceAttr == 0xFFFFFFFF) {
nativeErrfile = nativeSource;
goto end;
}
if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* Process the symbolic link
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
| | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
TCL_UNUSED(const WCHAR *) /*dstPtr*/,
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(nativeSrc) == TCL_OK) {
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
| | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
if (result == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
/*
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 |
*/
attr = 0;
}
}
}
| | | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
*/
attr = 0;
}
}
}
TclNewIntObj(*attributePtrPtr, attr != 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertFileNameFormat --
|
| ︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 |
*
*----------------------------------------------------------------------
*/
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
*
*----------------------------------------------------------------------
*/
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
Tcl_Obj *splitPath;
|
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
| | | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
if (fileAttributes == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
1888 1889 1890 1891 1892 1893 1894 |
*/
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
| | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
*/
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
TCL_UNUSED(Tcl_Obj *) /*attributePtr*/)
{
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
tclpFileAttrStrings[objIndex], Tcl_GetString(fileName)));
errno = EINVAL;
Tcl_PosixError(interp);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1922 1923 1924 1925 1926 1927 1928 |
TclpObjListVolumes(void)
{
Tcl_Obj *resultPtr, *elemPtr;
char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
int i;
char *p;
| | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
TclpObjListVolumes(void)
{
Tcl_Obj *resultPtr, *elemPtr;
char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
int i;
char *p;
TclNewObj(resultPtr);
/*
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
|
| ︙ | ︙ |
Changes to win/tclWinFile.c.
1 2 3 4 5 6 7 8 | /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. * * Copyright © 1995-1998 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" |
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
*/
return 0;
}
TclWinConvertError(GetLastError());
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
| > | | | > > > > > > > > | > | 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 |
*/
return 0;
}
TclWinConvertError(GetLastError());
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
if (!tclWinProcs.createSymbolicLink) {
/*
* Can't symlink files.
*/
Tcl_SetErrno(EINVAL);
} else if (tclWinProcs.createSymbolicLink(linkSourcePath, linkTargetPath,
0x2 /* SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE */)) {
/*
* Success!
*/
return 0;
} else {
TclWinConvertError(GetLastError());
}
} else {
Tcl_SetErrno(ENODEV);
}
} else {
/*
* We've got a directory. Now check whether what we're trying to do is
* reasonable.
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 | */ int len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; const char *str = TclGetStringFromObj(norm, &len); | | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 |
*/
int len;
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
const char *str = TclGetStringFromObj(norm, &len);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
attr = data.dwFileAttributes;
|
| ︙ | ︙ | |||
975 976 977 978 979 980 981 | return TCL_ERROR; } /* * Verify that the specified path exists and is actually a directory. */ | | | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
return TCL_ERROR;
}
/*
* Verify that the specified path exists and is actually a directory.
*/
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)) {
|
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 |
* Now iterate over all of the files in the directory, starting with
* the first one we found.
*/
do {
const char *utfname;
int checkDrive = 0, isDrive;
| < | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
* Now iterate over all of the files in the directory, starting with
* the first one we found.
*/
do {
const char *utfname;
int checkDrive = 0, isDrive;
native = data.cFileName;
attr = data.dwFileAttributes;
Tcl_DStringInit(&ds);
utfname = Tcl_WCharToUtfDString(native, -1, &ds);
if (!matchSpecialDots) {
|
| ︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 |
&& path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'com[1-9]:?', which is a serial port.
*/
if (path[4] == '\0') {
return 4;
| | | | 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 |
&& path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'com[1-9]:?', which is a serial port.
*/
if (path[4] == '\0') {
return 4;
} else if (path[4] == ':' && path[5] == '\0') {
return 4;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
/*
* Have match for 'con'
*/
return 3;
}
} else if ((path[0] == 'l' || path[0] == 'L')
&& (path[1] == 'p' || path[1] == 'P')
&& (path[2] == 't' || path[2] == 'T')) {
if (path[3] >= '1' && path[3] <= '9') {
/*
* May have match for 'lpt[1-9]:?'
*/
if (path[4] == '\0') {
return 4;
} else if (path[4] == ':' && path[5] == '\0') {
return 4;
}
}
} else if (!strcasecmp(path, "prn") || !strcasecmp(path, "nul")
|| !strcasecmp(path, "aux")) {
/*
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 |
char *result = NULL;
USER_INFO_1 *uiPtr;
Tcl_DString ds;
int nameLen = -1;
int rc = 0;
const char *domain;
WCHAR *wName, *wHomeDir, *wDomain;
| < | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 |
char *result = NULL;
USER_INFO_1 *uiPtr;
Tcl_DString ds;
int nameLen = -1;
int rc = 0;
const char *domain;
WCHAR *wName, *wHomeDir, *wDomain;
Tcl_DStringInit(bufferPtr);
wDomain = NULL;
domain = Tcl_UtfFindFirst(name, '@');
if (domain == NULL) {
const char *ptr;
|
| ︙ | ︙ | |||
1497 1498 1499 1500 1501 1502 1503 |
* Get current domain
*/
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
if (rc != 0) {
break;
}
| | > | 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 |
* Get current domain
*/
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
if (rc != 0) {
break;
}
domain = (const char *)INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) {
size = lstrlenW(wHomeDir);
Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
WCHAR buf[MAX_PATH];
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
Tcl_WCharToUtfDString(buf, size-1, bufferPtr);
|
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 |
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
| | | 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 |
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
nativePath = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
result = SetCurrentDirectoryW(nativePath);
if (result == 0) {
|
| ︙ | ︙ | |||
2009 2010 2011 2012 2013 2014 2015 |
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
| | | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 |
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
/*
*----------------------------------------------------------------------
*
* NativeStat --
*
|
| ︙ | ︙ | |||
2203 2204 2205 2206 2207 2208 2209 |
const WCHAR *nativeVol;
Tcl_DString volString;
p = strchr(fullPath + 2, '\\');
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
| | | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 |
const WCHAR *nativeVol;
Tcl_DString volString;
p = strchr(fullPath + 2, '\\');
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformationW()
* won't work.
*/
fullPath = TclDStringAppendLiteral(&ds, "\\");
p = fullPath + Tcl_DStringLength(&ds);
} else {
p++;
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 |
}
int
TclpObjAccess(
Tcl_Obj *pathPtr,
int mode)
{
| | | | | | | 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 |
}
int
TclpObjAccess(
Tcl_Obj *pathPtr,
int mode)
{
return NativeAccess((const WCHAR *)Tcl_FSGetNativePath(pathPtr), mode);
}
int
TclpObjLstat(
Tcl_Obj *pathPtr,
Tcl_StatBuf *statPtr)
{
/*
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
int res;
const WCHAR *LinkTarget;
const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);
if (normalizedToPtr == NULL) {
return NULL;
}
LinkTarget = (const WCHAR *)Tcl_FSGetNativePath(normalizedToPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
res = WinLink(LinkSource, LinkTarget, linkAction);
if (res == 0) {
return toPtr;
} else {
return NULL;
}
} else {
const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
}
return WinReadLink(LinkSource);
}
}
|
| ︙ | ︙ | |||
2477 2478 2479 2480 2481 2482 2483 |
path = Tcl_GetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
| | | | 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 |
path = Tcl_GetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
Tcl_IncrRefCount(driveName);
found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(driveName),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
if (found == 0) {
return NULL;
} else {
|
| ︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 | * modified in place. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath( | | | 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 |
* modified in place.
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize */
int nextCheckpoint) /* offset to start at in pathPtr */
{
char *lastValidPathEnd = NULL;
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
|
| ︙ | ︙ | |||
2814 2815 2816 2817 2818 2819 2820 |
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
int len;
| < | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 |
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
int len;
Tcl_Obj *tmpPathPtr;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = TclGetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
|
| ︙ | ︙ | |||
3110 3111 3112 3113 3114 3115 3116 |
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
| | | > | 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 |
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = (WCHAR *)ckalloc((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
* slashes to backslashes but leave the '?' intact
*/
if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
|
| ︙ | ︙ | |||
3208 3209 3210 3211 3212 3213 3214 |
if (clientData == NULL) {
return NULL;
}
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
| | | 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 |
if (clientData == NULL) {
return NULL;
}
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3245 3246 3247 3248 3249 3250 3251 |
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
| | | 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 |
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
attr = GetFileAttributesW(native);
if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) {
flags = FILE_FLAG_BACKUP_SEMANTICS;
}
|
| ︙ | ︙ | |||
3296 3297 3298 3299 3300 3301 3302 |
PSID ownerSid = NULL;
PSECURITY_DESCRIPTOR secd = NULL;
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
| | | 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
PSID ownerSid = NULL;
PSECURITY_DESCRIPTOR secd = NULL;
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
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.
|
| ︙ | ︙ | |||
3324 3325 3326 3327 3328 3329 3330 |
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
| | | 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 |
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
buf = (LPBYTE)ckalloc(bufsz);
if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
}
}
CloseHandle(token);
}
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
1 2 3 4 5 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * 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 "tclWinInt.h" |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | /* * Windows version dependend functions */ TclWinProcs tclWinProcs; /* | | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
/*
* Windows version dependend functions
*/
TclWinProcs tclWinProcs;
/*
* The following arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
#endif
/*
* Fill available functions depending on windows version
*/
handle = GetModuleHandleW(L"KERNEL32");
tclWinProcs.cancelSynchronousIo =
| | > > > | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
#endif
/*
* Fill available functions depending on windows version
*/
handle = GetModuleHandleW(L"KERNEL32");
tclWinProcs.cancelSynchronousIo =
(BOOL (WINAPI *)(HANDLE))(void *)GetProcAddress(handle,
"CancelSynchronousIo");
tclWinProcs.createSymbolicLink =
(BOOLEAN (WINAPI *)(LPCWSTR, LPCWSTR, DWORD))(void *)GetProcAddress(handle,
"CreateSymbolicLinkW");
}
/*
*-------------------------------------------------------------------------
*
* TclpInitLibraryPath --
*
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
int length;
| | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
int length;
TclNewObj(pathPtr);
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
*/
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
| | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
*valuePtr = (char *)ckalloc(length);
memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
| | | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
| | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
| | | > | 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 |
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *))(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);
wsprintfA(buffer, "%d.%d", 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);
}
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, length, result = -1;
| > > > > | | | > > > | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
# define tenviron2utfdstr(string, len, dsPtr) \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, length, result = -1;
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 *)ckalloc(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, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = (int) (p1 - envUpper);
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
|
| ︙ | ︙ |
Changes to win/tclWinInt.h.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
#endif
/*
* Windows version dependend functions
*/
typedef struct TclWinProcs {
BOOL (WINAPI *cancelSynchronousIo)(HANDLE);
} TclWinProcs;
MODULE_SCOPE TclWinProcs tclWinProcs;
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
| > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
#endif
/*
* Windows version dependend functions
*/
typedef struct TclWinProcs {
BOOL (WINAPI *cancelSynchronousIo)(HANDLE);
BOOLEAN (WINAPI *createSymbolicLink)(LPCWSTR, LPCWSTR, DWORD);
} TclWinProcs;
MODULE_SCOPE TclWinProcs tclWinProcs;
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
1 2 3 4 5 6 7 | /* * tclWinLoad.c -- * * This function provides a version of the TclLoadFile that works with * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic * loading. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclWinLoad.c -- * * This function provides a version of the TclLoadFile that works with * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic * loading. * * 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" |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
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. */
| | | | 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 |
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. */
TCL_UNUSED(int) /*flags*/)
{
HINSTANCE hInstance = NULL;
const WCHAR *nativeName;
Tcl_LoadHandle handlePtr;
DWORD firstError;
/*
* 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.
*/
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName != NULL) {
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
}
if (hInstance == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
handlePtr = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
handlePtr->clientData = (ClientData) hInstance;
handlePtr->findSymbolProcPtr = &FindSymbol;
handlePtr->unloadFileProcPtr = &UnloadFile;
*loadHandle = handlePtr;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
| | | | | 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 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
void *proc = NULL;
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
*/
proc = (void *)GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
sym2 = Tcl_DStringAppend(&ds, symbol, -1);
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, NULL);
}
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclpTempFileNameForLibrary --
*
* Constructs a temporary file name for loading a shared object (DLL).
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
| | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
dllDirectoryName = (WCHAR *)ckalloc((nameLen+1) * sizeof(WCHAR));
wcscpy(dllDirectoryName, name);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinNotify.c.
1 2 3 4 5 6 7 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, which * is the lowest-level part of the Tcl event loop. This file works * together with ../generic/tclNotify.c. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, which * is the lowest-level part of the Tcl event loop. This file works * together with ../generic/tclNotify.c. * * 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" |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TclpGlobalLock();
if (!initialized) {
initialized = 1;
InitializeCriticalSection(¬ifierMutex);
}
TclpGlobalUnlock();
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
EnterCriticalSection(¬ifierMutex);
|
| ︙ | ︙ |
Changes to win/tclWinPanic.c.
1 2 3 4 5 | /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. * * Copyright © 2013 Jan Nijtmans. * 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" |
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
1 2 3 4 5 6 | /* * tclWinPipe.c -- * * This file implements the Windows-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinPipe.c -- * * This file implements the Windows-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. * * Copyright © 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. */ #include "tclWinInt.h" |
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void PipeSetupProc( | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
PipeSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 | * May queue an event. * *---------------------------------------------------------------------- */ static void PipeCheckProc( | | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
PipeCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
PipeEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
| | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
evPtr = (PipeEvent *)ckalloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
filePtr = (WinFile *)ckalloc(sizeof(WinFile));
filePtr->type = WIN_FILE;
filePtr->handle = handle;
return (TclFile)filePtr;
}
/*
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
return NULL;
}
/*
|
| ︙ | ︙ | |||
1303 1304 1305 1306 1307 1308 1309 | /* * Ignore matches on directories or data files, return if identified a * known type. */ attr = GetFileAttributesW(nativeFullPath); | | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 |
/*
* Ignore matches on directories or data files, return if identified a
* known type.
*/
attr = GetFileAttributesW(nativeFullPath);
if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
| | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
PipeInfo *infoPtr = (PipeInfo *)ckalloc(sizeof(PipeInfo));
PipeInit();
infoPtr->watchMask = 0;
infoPtr->flags = 0;
infoPtr->readFlags = 0;
infoPtr->readFile = readFile;
|
| ︙ | ︙ | |||
1852 1853 1854 1855 1856 1857 1858 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result.*/
Tcl_Channel *rchan, /* Where to return the read side. */
Tcl_Channel *wchan, /* Where to return the write side. */
| | | 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result.*/
Tcl_Channel *rchan, /* Where to return the read side. */
Tcl_Channel *wchan, /* Where to return the write side. */
TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
HANDLE readHandle, writeHandle;
SECURITY_ATTRIBUTES sec;
sec.nLength = sizeof(SECURITY_ATTRIBUTES);
sec.lpSecurityDescriptor = NULL;
sec.bInheritHandle = FALSE;
|
| ︙ | ︙ | |||
1913 1914 1915 1916 1917 1918 1919 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
| | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = (PipeInfo *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
Tcl_NewWideIntObj((unsigned)
TclpGetPid(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
|
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
| | | 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = toWrite;
} else {
|
| ︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 |
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
unsigned long id) /* Global process identifier */
{
| | | 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 |
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
unsigned long id) /* Global process identifier */
{
ProcInfo *procPtr = (ProcInfo*)ckalloc(sizeof(ProcInfo));
PipeInit();
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PidObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
|
| ︙ | ︙ | |||
2768 2769 2770 2771 2772 2773 2774 |
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
| | | 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 |
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
TclNewObj(resultPtr);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
Tcl_NewWideIntObj((unsigned)
TclpGetPid(pipePtr->pidPtr[i])));
}
Tcl_SetObjResult(interp, resultPtr);
}
|
| ︙ | ︙ | |||
2808 2809 2810 2811 2812 2813 2814 |
static int
WaitForRead(
PipeInfo *infoPtr, /* Pipe state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
| | | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 |
static int
WaitForRead(
PipeInfo *infoPtr, /* Pipe state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
HANDLE *handle = (HANDLE *)((WinFile *) infoPtr->readFile)->handle;
while (1) {
/*
* Synchronize with the reader thread.
*/
/* avoid blocking if pipe-thread exited */
|
| ︙ | ︙ | |||
3185 3186 3187 3188 3189 3190 3191 | * A read-write Tcl Channel open on the file. * *---------------------------------------------------------------------- */ Tcl_Channel TclpOpenTemporaryFile( | | | | 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 |
* A read-write Tcl Channel open on the file.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenTemporaryFile(
TCL_UNUSED(Tcl_Obj *) /*dirObj*/,
Tcl_Obj *basenameObj,
TCL_UNUSED(Tcl_Obj *) /*extensionObj*/,
Tcl_Obj *resultingNameObj)
{
WCHAR name[MAX_PATH];
char *namePtr;
HANDLE handle;
DWORD flags = FILE_ATTRIBUTE_TEMPORARY;
int length, counter, counter2;
|
| ︙ | ︙ | |||
3282 3283 3284 3285 3286 3287 3288 |
TclPipeThreadCreateTI(
TclPipeThreadInfo **pipeTIPtr,
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
| | | | 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 |
TclPipeThreadCreateTI(
TclPipeThreadInfo **pipeTIPtr,
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = (TclPipeThreadInfo *)malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = (TclPipeThreadInfo *)ckalloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
pipeTI->evWakeUp = wakeEvent;
return (*pipeTIPtr = pipeTI);
}
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
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. */ #ifndef _TCLWINPORT #define _TCLWINPORT | < | | 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 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT #if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ # define __MINGW_USE_VC2005_COMPAT #endif #if defined(_MSC_VER) && defined(_WIN64) && !defined(STATIC_BUILD) \ && !defined(MP_32BIT) && !defined(MP_64BIT) # define MP_64BIT #endif /* * We must specify the lower version we intend to support. * * WINVER = 0x0501 means Windows XP and above */ #ifndef WINVER # define WINVER 0x0501 #endif #ifndef _WIN32_WINNT # define _WIN32_WINNT 0x0501 |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | typedef DWORD DWORD_PTR; typedef DWORD_PTR * PDWORD_PTR; #endif /* * Ask for the winsock function typedefs, also. */ | > | > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | typedef DWORD DWORD_PTR; typedef DWORD_PTR * PDWORD_PTR; #endif /* * Ask for the winsock function typedefs, also. */ #ifndef INCL_WINSOCK_API_TYPEDEFS # define INCL_WINSOCK_API_TYPEDEFS 1 #endif #include <winsock2.h> #include <ws2tcpip.h> #ifdef HAVE_WSPIAPI_H # include <wspiapi.h> #endif /* |
| ︙ | ︙ | |||
292 293 294 295 296 297 298 | #endif /* * Supply definitions for macros to query wait status, if not already * defined in header files above. */ | | | | | 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 | #endif /* * Supply definitions for macros to query wait status, if not already * defined in header files above. */ #ifdef TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int #endif /* TCL_UNION_WAIT */ #ifndef WIFEXITED # define WIFEXITED(stat) (((*((int *) &(stat))) & 0xC0000000) == 0) #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (*((int *) &(stat))) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) 0 #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* * Define constants for waitpid() system call if they aren't defined * by a system header file. */ |
| ︙ | ︙ | |||
434 435 436 437 438 439 440 | # define MAXPATHLEN MAXPATH #endif /* MAXPATHLEN */ /* * Define pid_t and uid_t if they're not already defined. */ | | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | # define MAXPATHLEN MAXPATH #endif /* MAXPATHLEN */ /* * Define pid_t and uid_t if they're not already defined. */ #if !defined(TCL_PID_T) # define pid_t int #endif /* !TCL_PID_T */ #if !defined(TCL_UID_T) # define uid_t int #endif /* !TCL_UID_T */ /* * Visual C++ has some odd names for common functions, so we need to * define a few macros to handle them. Also, it defines EDEADLOCK and * EDEADLK as the same value, which confuses Tcl_ErrnoId(). |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
1231 1232 1233 1234 1235 1236 1237 |
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD))
| | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD))
(void *)GetProcAddress(handle, "RegDeleteKeyExW");
}
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKeyW(startKey, keyName);
}
break;
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
1 2 3 4 5 6 | /* * tclWinSerial.c -- * * This file implements the Windows-specific serial port functions, and * the "serial" channel driver. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinSerial.c -- * * This file implements the Windows-specific serial port functions, and * the "serial" channel driver. * * Copyright © 1999 Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Serial functionality implemented by Rolf.Schroedter@dlr.de */ |
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | /* * Declarations for functions used only in this file. */ static int SerialBlockProc(ClientData instanceData, int mode); static void SerialCheckProc(ClientData clientData, int flags); static int SerialCloseProc(ClientData instanceData, | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | /* * Declarations for functions used only in this file. */ static int SerialBlockProc(ClientData instanceData, int mode); static void SerialCheckProc(ClientData clientData, int flags); static int SerialCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int SerialEventProc(Tcl_Event *evPtr, int flags); static void SerialExitHandler(ClientData clientData); static int SerialGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static ThreadSpecificData *SerialInit(void); static int SerialInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); |
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
SerialInputProc, /* Input proc. */
SerialOutputProc, /* Output proc. */
NULL, /* Seek proc. */
SerialSetOptionProc, /* Set option proc. */
SerialGetOptionProc, /* Get option proc. */
SerialWatchProc, /* Set up notifier to watch the channel. */
SerialGetHandleProc, /* Get an OS handle from channel. */
SerialCloseProc, /* close2proc. */
SerialBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
SerialThreadActionProc, /* thread action proc */
NULL /* truncate */
};
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 | * Removes the serial event source. * *---------------------------------------------------------------------- */ static void SerialExitHandler( | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
* Removes the serial event source.
*
*----------------------------------------------------------------------
*/
static void
SerialExitHandler(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
SerialInfo *infoPtr;
/*
* Clear all eventually pending output. Otherwise Tcl's exit could totally
* block, because it performs a blocking flush on all open channels. Note
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&serialMutex);
initialized = 0;
Tcl_MutexUnlock(&serialMutex);
}
/*
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 403 404 | * * Side effects: * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SerialSetupProc( | > > > > | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
*
* Side effects:
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
#ifdef __cplusplus
#define min(a, b) (((a) < (b)) ? (a) : (b))
#endif
void
SerialSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
int block = 1;
int msec = INT_MAX; /* min. found block time */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | * May queue an event. * *---------------------------------------------------------------------- */ static void SerialCheckProc( | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SerialCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
SerialEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
COMSTAT cStat;
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
evPtr = (SerialEvent *)ckalloc(sizeof(SerialEvent));
evPtr->header.proc = SerialEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
*
*----------------------------------------------------------------------
*/
static int
SerialCloseProc(
ClientData instanceData, /* Pointer to SerialInfo structure. */
| | > | > > > | | 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 |
*
*----------------------------------------------------------------------
*/
static int
SerialCloseProc(
ClientData 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;
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
| | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->evWritable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = (DWORD) toWrite;
|
| ︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 |
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
| | | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 |
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
| | | 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
infoPtr = (SerialInfo *)ckalloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
infoPtr->readable = 0;
infoPtr->writable = 1;
|
| ︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 |
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
| | | | | | | | | 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 |
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
int i, res = TCL_OK;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
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", NULL);
}
ckfree(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", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", 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", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", 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", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
"FCONFIGURE", "TTY_SIGNAL", 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",
NULL);
}
res = TCL_ERROR;
break;
}
}
ckfree(argv);
return res;
}
/*
* Option -sysbuffer {read_size write_size}
* Option -sysbuffer read_size
*/
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
1 2 3 4 5 | /* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * 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. * * ----------------------------------------------------------------------- * The order and naming of functions in this file should minimize * the file diff to tclUnixSock.c. |
| ︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TcpCloseProc, /* Close proc. */
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
| > > > > | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
#else
TCL_CLOSE2PROC, /* Close proc. */
#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
/*
* Simple wrapper round the SendMessage syscall.
*/
#define SendSelectMessage(tsdPtr, message, payload) \
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
/*
* Simple wrapper round the SendMessage syscall.
*/
#define SendSelectMessage(tsdPtr, message, payload) \
SendMessageW((tsdPtr)->hwnd, SOCKET_SELECT, \
(WPARAM) (message), (LPARAM) (payload))
/*
* Address print debug functions
*/
#if 0
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf)/sizeof(WCHAR);
Tcl_DString ds;
Tcl_DStringInit(&ds);
| | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
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 native to UTF then change to lowercase.
*/
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds));
} else {
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
| | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
| | | | 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 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Careful! This is a finalizer!
*/
if (tsdPtr == NULL) {
return;
}
if (tsdPtr->socketThread != NULL) {
if (tsdPtr->hwnd != NULL) {
PostMessageW(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
/*
* Wait for the thread to exit. This ensures that we are
* completely cleaned up before we leave this function.
*/
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * * Side effects: * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ | < | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
*
* Side effects:
* Sets the device into blocking or nonblocking mode.
*
*----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
ClientData 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) {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
}
return 0;
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
/*
* Loop in the blocking case until the connect signal is present
*/
while (1) {
/*
| | | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
/*
* Loop in the blocking case until the connect signal is present
*/
while (1) {
/*
* Get the statePtr lock.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Check for connect event.
*/
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 | * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
ClientData 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;
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
static int
TcpOutputProc(
ClientData instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
| | | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
static int
TcpOutputProc(
ClientData 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 that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | * * Side effects: * Closes the socket. * *---------------------------------------------------------------------- */ | < | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
*
* Side effects:
* Closes the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
| | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 |
static int
TcpClose2Proc(
ClientData 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.
*/
|
| ︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 |
*/
static int
TcpSetOptionProc(
ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
| | > > | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
*/
static int
TcpSetOptionProc(
ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
TCL_UNUSED(const char *) /*value*/) /* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
TcpState *statePtr = instanceData;
SOCKET sock;
#else
(void)instanceData;
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
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. */
{
| | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
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"
/*
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 |
static void
TcpWatchProc(
ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
| | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
static void
TcpWatchProc(
ClientData 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;
/*
* Update the watch events mask. Only if the socket is not a server
* socket. [Bug 557878]
*/
if (!statePtr->acceptProc) {
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
ClientData instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
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. */
| | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
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) {
|
| ︙ | ︙ | |||
2137 2138 2139 2140 2141 2142 2143 |
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
| | | 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 |
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Set kernel space buffering and non-blocking.
*/
TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);
|
| ︙ | ︙ | |||
2329 2330 2331 2332 2333 2334 2335 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
| | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
/*
|
| ︙ | ︙ | |||
2385 2386 2387 2388 2389 2390 2391 | * Side effects: * Creates a new connection socket. Calls the registered callback for the * connection acceptance mechanism. * *---------------------------------------------------------------------- */ | < | | 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 |
* Side effects:
* Creates a new connection socket. Calls the registered callback for the
* connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
TcpFdList *fds, /* Server socket that accepted newSocket. */
SOCKET newSocket, /* Newly accepted socket. */
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);
|
| ︙ | ︙ | |||
2468 2469 2470 2471 2472 2473 2474 |
*----------------------------------------------------------------------
*/
static void
InitSockets(void)
{
DWORD id;
| | | 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 |
*----------------------------------------------------------------------
*/
static void
InitSockets(void)
{
DWORD id;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (!initialized) {
initialized = 1;
TclCreateLateExitHandler(SocketExitHandler, NULL);
/*
* Create the async notification window with a new class. We must
|
| ︙ | ︙ | |||
2517 2518 2519 2520 2521 2522 2523 |
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->pendingTcpState = NULL;
tsdPtr->socketList = NULL;
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
| | | | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
*/
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;
}
tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
&id);
if (tsdPtr->socketThread == NULL) {
goto initFailure;
|
| ︙ | ︙ | |||
2574 2575 2576 2577 2578 2579 2580 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SocketsEnabled(void)
{
int enabled;
Tcl_MutexLock(&socketMutex);
enabled = (initialized == 1);
|
| ︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
SocketExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&socketMutex);
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
|
| ︙ | ︙ | |||
2641 2642 2643 2644 2645 2646 2647 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SocketSetupProc( | | | 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
SocketSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
2686 2687 2688 2689 2690 2691 2692 | * May queue an event. * *---------------------------------------------------------------------- */ static void SocketCheckProc( | | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SocketCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
SocketEvent *evPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 |
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);
| | | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
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 *)ckalloc(sizeof(SocketEvent));
evPtr->header.proc = SocketEventProc;
evPtr->socket = statePtr->sockets->fd;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
SetEvent(tsdPtr->socketListLock);
}
|
| ︙ | ︙ | |||
2985 2986 2987 2988 2989 2990 2991 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
| | | | 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 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
statePtr->sockets = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = statePtr->sockets;
} else {
/*
* Find end of list and append FD.
*/
while (fds->next != NULL) {
fds = fds->next;
}
fds->next = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = fds->next;
}
/*
* Populate new FD.
*/
|
| ︙ | ︙ | |||
3029 3030 3031 3032 3033 3034 3035 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
| | | 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
TcpState *statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
|
| ︙ | ︙ | |||
3072 3073 3074 3075 3076 3077 3078 |
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;
| | | 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 |
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);
|
| ︙ | ︙ | |||
3158 3159 3160 3161 3162 3163 3164 |
*/
static DWORD WINAPI
SocketThread(
LPVOID arg)
{
MSG msg;
| | | 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 |
*/
static DWORD WINAPI
SocketThread(
LPVOID arg)
{
MSG msg;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)arg;
/*
* Create a dummy window receiving socket events.
*/
tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0,
NULL, NULL, windowClass.hInstance, arg);
|
| ︙ | ︙ | |||
3184 3185 3186 3187 3188 3189 3190 |
if (tsdPtr->hwnd == NULL) {
return 1;
}
/*
* Process all messages on the socket window until WM_QUIT. This threads
* exits only when instructed to do so by the call to
| | | 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 |
if (tsdPtr->hwnd == NULL) {
return 1;
}
/*
* Process all messages on the socket window until WM_QUIT. This threads
* exits only when instructed to do so by the call to
* PostMessageW(SOCKET_TERMINATE) in TclpFinalizeSockets().
*/
while (GetMessageW(&msg, NULL, 0, 0) > 0) {
DispatchMessageW(&msg);
}
/*
|
| ︙ | ︙ | |||
3250 3251 3252 3253 3254 3255 3256 |
case WM_CREATE:
/*
* Store the initial tsdPtr, it's from a different thread, so it's not
* directly accessible, but needed.
*/
#ifdef _WIN64
| | | 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
case WM_CREATE:
/*
* Store the initial tsdPtr, it's from a different thread, so it's not
* directly accessible, but needed.
*/
#ifdef _WIN64
SetWindowLongPtrW(hwnd, GWLP_USERDATA,
(LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
SetWindowLongW(hwnd, GWL_USERDATA,
(LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
break;
|
| ︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 |
static void
TcpThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
| | | 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 |
static void
TcpThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
TcpState *statePtr = (TcpState *)instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
/*
* Ensure that socket subsystem is initialized in this thread, or else
* sockets will not work.
*/
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
1 2 3 4 5 | /* * tclWinTest.c -- * * Contains commands for platform specific tests on Windows. * | | > > > | > | < | < < | < | < | < | < | 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 | /* * tclWinTest.c -- * * Contains commands for platform specific tests on Windows. * * Copyright © 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. */ #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 /* * For TestplatformChmod on Windows */ #ifdef _WIN32 #include <aclapi.h> #endif /* * MinGW 3.4.2 does not define this. */ #ifndef INHERITED_ACE #define INHERITED_ACE (0x10) #endif /* * Forward declarations of functions defined later in this file: */ static Tcl_ObjCmdProc TesteventloopCmd; static Tcl_ObjCmdProc TestvolumetypeCmd; static Tcl_ObjCmdProc TestwinclockCmd; static Tcl_ObjCmdProc TestwinsleepCmd; static Tcl_ObjCmdProc TestSizeCmd; static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); static Tcl_ObjCmdProc TestchmodCmd; /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * * Defines commands that test platform specific functionality for Windows |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | * None. * *---------------------------------------------------------------------- */ static int TesteventloopCmd( | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | * None. * *---------------------------------------------------------------------- */ static int TestvolumetypeCmd( | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestvolumetypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#define VOL_BUF_SIZE 32
int found;
char volType[VOL_BUF_SIZE];
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 | * None. * *---------------------------------------------------------------------- */ static int TestwinclockCmd( | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestwinclockCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a Windows
* FILETIME */
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 |
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static int
TestwinsleepCmd(
| | | > | 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 |
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static int
TestwinsleepCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int ms;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "ms");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
Sleep((DWORD) ms);
return TCL_OK;
}
static int
TestSizeCmd(
TCL_UNUSED(ClientData),
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]), "time_t") == 0) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t)));
return TCL_OK;
}
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 | * This Tcl process closes, hard... Bang! * *---------------------------------------------------------------------- */ static int TestExceptionCmd( | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
* This Tcl process closes, hard... Bang!
*
*----------------------------------------------------------------------
*/
static int
TestExceptionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const char *const cmds[] = {
"access_violation", "datatype_misalignment", "array_bounds",
"float_denormal", "float_divbyzero", "float_inexact",
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
| < | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
return TCL_OK;
}
static int
TestplatformChmod(
const char *nativePath,
int pmode)
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
if (attr == 0xFFFFFFFF) {
res = -1;
goto done;
}
/*
* If nativePath is not a directory, there is no special handling.
*/
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
| | | | 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 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
secDesc = (BYTE *)ckalloc(secDescLen);
if (!GetFileSecurityA(nativePath, infoBits,
(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
goto done;
}
}
/*
* Get the World SID.
*/
userSid = (SID *)ckalloc(GetSidLengthRequired((UCHAR) 1));
InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
*(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
/*
* If curAclPresent == false then curAcl and curAclDefaulted not valid.
*/
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
| | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
newAcl = (PACL) ckalloc(newAclSize);
/*
* Initialize the new ACL.
*/
if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) {
goto done;
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 | * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int i, mode;
if (objc < 2) {
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
1 2 3 4 5 | /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * | | | | | | | | 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 | /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif /* * This is the global lock used to serialize access to other serialization * data structures. */ static CRITICAL_SECTION globalLock; static int initialized = 0; /* * This is the global lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. For |
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | * interpreter has been created, it is safe to create more threads * that create interpreters in parallel. */ initialized = 1; InitializeCriticalSection(&joinLock); InitializeCriticalSection(&initLock); | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
* interpreter has been created, it is safe to create more threads
* that create interpreters in parallel.
*/
initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
}
EnterCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
{
LeaveCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | 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 |
{
LeaveCriticalSection(&initLock);
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalLock
*
* This procedure is used to grab a lock that serializes creation of
* mutexes, condition variables, and thread local storage keys.
*
* This lock must be different than the initLock because the initLock is
* held during creation of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Acquire the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalLock(void)
{
if (!initialized) {
/*
* There is a fundamental race here that is solved by creating the
* first Tcl interpreter in a single threaded environment. Once the
* interpreter has been created, it is safe to create more threads
* that create interpreters in parallel.
*/
initialized = 1;
InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&globalLock);
}
EnterCriticalSection(&globalLock);
}
/*
*----------------------------------------------------------------------
*
* TclpGlobalUnlock
*
* This procedure is used to release a lock that serializes creation and
* deletion of synchronization objects.
*
* Results:
* None.
*
* Side effects:
* Release the global mutex.
*
*----------------------------------------------------------------------
*/
void
TclpGlobalUnlock(void)
{
LeaveCriticalSection(&globalLock);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAllocMutex
*
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
| | | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock(void)
{
TclpGlobalLock();
DeleteCriticalSection(&joinLock);
/*
* Destroy the critical section that we are holding!
*/
DeleteCriticalSection(&globalLock);
initialized = 0;
#if TCL_THREADS
if (allocOnce) {
DeleteCriticalSection(&allocLock.crit);
allocOnce = 0;
}
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* The lock */
{
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
| | | | | | 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 |
void
Tcl_MutexLock(
Tcl_Mutex *mutexPtr) /* The lock */
{
CRITICAL_SECTION *csPtr;
if (*mutexPtr == NULL) {
TclpGlobalLock();
/*
* Double inside global lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
EnterCriticalSection(csPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
/*
* Self initialize the two parts of the condition. The per-condition and
* per-thread parts need to be handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
| | | | | | | | | 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 |
/*
* Self initialize the two parts of the condition. The per-condition and
* per-thread parts need to be handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
TclpGlobalLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
FALSE /* non signaled */, NULL);
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
TclpGlobalUnlock();
if (doExit) {
/*
* Create a per-thread exit handler to clean up the condEvent. We
* must be careful to do this outside the Global Lock because
* Tcl_CreateThreadExitHandler uses its own ThreadSpecificData,
* and initializing that may drop back into the Global Lock.
*/
Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr);
}
}
if (*condPtr == NULL) {
TclpGlobalLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
TclpGlobalUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
winCondPtr = *((WinCondition **)condPtr);
if (timePtr == NULL) {
wtime = INFINITE;
} else {
wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * | | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | *---------------------------------------------------------------------- * * TclpFinalizeCondition -- * * This procedure is invoked to clean up a condition variable. This is * only safe to call at the end of time. * * This assumes the Global Lock is held. * * Results: * None. * * Side effects: * The condition variable is deallocated. * |
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
#ifdef USE_THREAD_ALLOC
Tcl_Mutex *
TclpNewAllocMutex(void)
{
allocMutex *lockPtr;
| | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 |
#ifdef USE_THREAD_ALLOC
Tcl_Mutex *
TclpNewAllocMutex(void)
{
allocMutex *lockPtr;
lockPtr = (allocMutex *)malloc(sizeof(allocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
InitializeCriticalSection(&lockPtr->wlock);
return &lockPtr->tlock;
}
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
void *
TclpThreadCreateKey(void)
{
DWORD *key;
| | | | | | | | | 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 |
void *
TclpThreadCreateKey(void)
{
DWORD *key;
key = (DWORD *)TclpSysAlloc(sizeof *key, 0);
if (key == NULL) {
Tcl_Panic("unable to allocate thread key!");
}
*key = TlsAlloc();
if (*key == TLS_OUT_OF_INDEXES) {
Tcl_Panic("unable to allocate thread-local storage");
}
return key;
}
void
TclpThreadDeleteKey(
void *keyPtr)
{
DWORD *key = (DWORD *)keyPtr;
if (!TlsFree(*key)) {
Tcl_Panic("unable to delete key");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetGlobalTSD(
void *tsdKeyPtr,
void *ptr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
if (!TlsSetValue(*key, ptr)) {
Tcl_Panic("unable to set global TSD value");
}
}
void *
TclpThreadGetGlobalTSD(
void *tsdKeyPtr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
return TlsGetValue(*key);
}
#endif /* TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinTime.c.
1 2 3 4 5 6 | /* * tclWinTime.c -- * * Contains Windows specific versions of Tcl functions that obtain time * values from the operating system. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclWinTime.c -- * * Contains Windows specific versions of Tcl functions that obtain time * values from the operating system. * * Copyright © 1995-1998 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" |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
{ NULL, 0, 0, NULL, NULL, 0 },
0,
0,
1,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
{ NULL, 0, 0, NULL, NULL, 0 },
0,
0,
1,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
(LARGE_INTEGER) (Tcl_WideInt) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
#else
{0, 0},
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 | * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime( | | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
* See above.
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
TCL_UNUSED(ClientData))
{
/*
* Native scale is 1:1. Nothing is done.
*/
}
/*
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 | */ SYSTEM_INFO systemInfo; int regs[4]; GetSystemInfo(&systemInfo); if (TclWinCPUID(0, regs) == TCL_OK | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
*/
SYSTEM_INFO systemInfo;
int regs[4];
GetSystemInfo(&systemInfo);
if (TclWinCPUID(0, regs) == TCL_OK
&& regs[1] == 0x756E6547 /* "Genu" */
&& regs[3] == 0x49656E69 /* "ineI" */
&& regs[2] == 0x6C65746E /* "ntel" */
&& TclWinCPUID(1, regs) == TCL_OK
&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
|| ((regs[0] & 0x00F00000) /* Extended family */
&& (regs[3] & 0x10000000))) /* Hyperthread */
&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
== (int)systemInfo.dwNumberOfProcessors)) {
timeInfo.perfCounterAvailable = TRUE;
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
| | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
TCL_UNUSED(ClientData))
{
Tcl_WideInt usecSincePosixEpoch;
/*
* Try to use high resolution timer.
*/
if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) {
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | *---------------------------------------------------------------------- */ void TclWinResetTimerResolution(void); static void StopCalibration( | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
*----------------------------------------------------------------------
*/
void TclWinResetTimerResolution(void);
static void
StopCalibration(
TCL_UNUSED(ClientData))
{
SetEvent(timeInfo.exitEvent);
/*
* If Tcl_Finalize was called from DllMain, the calibration thread is in a
* paused state so we need to timeout and continue.
*/
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 | * body of this procedure. * *---------------------------------------------------------------------- */ static DWORD WINAPI CalibrationThread( | | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
* body of this procedure.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
CalibrationThread(
TCL_UNUSED(LPVOID))
{
FILETIME curFileTime;
DWORD waitResult;
/*
* Get initial system time and performance counter.
*/
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
if (waitResult == WAIT_OBJECT_0) {
break;
}
UpdateTimeEachSecond();
}
| < | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 |
waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
if (waitResult == WAIT_OBJECT_0) {
break;
}
UpdateTimeEachSecond();
}
return (DWORD) 0;
}
/*
*----------------------------------------------------------------------
*
* UpdateTimeEachSecond --
|
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
* time in a block of thread-local storage, and Windows does not provide a
* Posix gmtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return gmtime(timePtr);
#else
| | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 |
* time in a block of thread-local storage, and Windows does not provide a
* Posix gmtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return gmtime(timePtr);
#else
return _gmtime32((const __time32_t *)timePtr);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpLocaltime --
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
* the time in a block of thread-local storage, and Windows does not
* provide a Posix localtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return localtime(timePtr);
#else
| | | 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 |
* the time in a block of thread-local storage, and Windows does not
* provide a Posix localtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return localtime(timePtr);
#else
return _localtime32((const __time32_t *)timePtr);
#endif
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |