Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merge old 8.7 674a6ad0472c7 |
|---|---|
| Timelines: | family | ancestors | descendants | both | tip-579-8-7 |
| Files: | files | file ages | folders |
| SHA3-256: |
72a2225a33d153dcc68111f4bd993a67 |
| User & Date: | kjnash 2022-08-31 14:28:57.007 |
Context
|
2022-08-31
| ||
| 15:24 | Merge old 8.7 6c69a72c58 check-in: 2bc437be78 user: kjnash tags: tip-579-8-7 | |
| 14:28 | Merge old 8.7 674a6ad0472c7 check-in: 72a2225a33 user: kjnash tags: tip-579-8-7 | |
| 12:51 | Merge old 8.7 9a14272d20 check-in: ca86e961bb user: kjnash tags: tip-579-8-7 | |
|
2020-12-01
| ||
| 11:56 | Merge-mark check-in: 674a6ad047 user: jan.nijtmans tags: core-8-branch | |
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 9 | 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 | < < | 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 .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 |
name: Linux
on: [push]
jobs:
gcc:
runs-on: ubuntu-20.04
strategy:
matrix:
cfgopt:
- ""
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "CFLAGS=-DTCL_UTF_MAX=4"
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 |
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 |
name: Windows
on: [push]
jobs:
msvc:
runs-on: windows-latest
defaults:
run:
shell: powershell
working-directory: win
# 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
run: |
&nmake -f makefile.vc all
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Build Test Harness
run: |
&nmake -f makefile.vc tcltest
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Run Tests
run: |
&nmake -f makefile.vc 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:
- ""
- "--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 .project.
1 2 3 4 5 6 7 8 9 10 11 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> <name>tcl8</name> <comment></comment> <projects> </projects> <buildSpec> </buildSpec> <natures> </natures> </projectDescription> | > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> <name>tcl8</name> <comment></comment> <projects> </projects> <buildSpec> <buildCommand> <name>org.eclipse.cdt.managedbuilder.core.genmakebuilder</name> <triggers>clean,full,incremental,</triggers> <arguments> </arguments> </buildCommand> <buildCommand> <name>org.eclipse.cdt.managedbuilder.core.ScannerConfigBuilder</name> <triggers>full,incremental,</triggers> <arguments> </arguments> </buildCommand> </buildSpec> <natures> <nature>org.eclipse.cdt.core.cnature</nature> <nature>org.eclipse.cdt.managedbuilder.core.managedBuildNature</nature> <nature>org.eclipse.cdt.managedbuilder.core.ScannerConfigNature</nature> </natures> </projectDescription> |
Changes to .travis.yml.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
language: c
addons:
apt:
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:
| > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
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"
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
- name: "Linux/G++/Shared"
os: linux
dist: focal
compiler: g++
env:
- BUILD_DIR=unix
- CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register"
| | | | < < | < < < < < < < < < < < < < < | | 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 |
- name: "Linux/G++/Shared"
os: linux
dist: focal
compiler: g++
env:
- BUILD_DIR=unix
- CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register"
# 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"
|
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
os: linux
dist: focal
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
| | | | | > | | | | | > > > > > > > > | | | 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 |
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
- name: "macOS/Clang++/Xcode 12/Shared"
os: osx
osx_image: xcode12.2
env:
- BUILD_DIR=unix
- CFGOPT="CC=clang++ --enable-framework --enable-dtrace CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern"
script:
- make all tcltest
# 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
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
- 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
- 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"
| > > | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
- 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
- rm -rf tests/safe-stock8*.test
- 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"
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test
- name: "Windows/MSVC/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
| > > > > > > > > > | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test
- name: "Windows/MSVC/StaticPackage"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc test
- name: "Windows/MSVC/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- choco install -y make zip
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=4"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
| > > | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- rm -rf tests/safe-stock8*.test
- 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
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
script:
- make dist
before_install:
- 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:
| > > | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
script:
- make dist
before_install:
- rm -rf tests/safe-stock8*.test
- 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.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 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 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 doc/CrtAlias.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_CreateAlias 3 7.6 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > > > | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 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/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/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.
| ︙ | ︙ | |||
220 221 222 223 224 225 226 | 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 | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | 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 |
| ︙ | ︙ |
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/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 |
| ︙ | ︙ | |||
758 759 760 761 762 763 764 765 766 767 768 769 770 771 | .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/chan.n.
| ︙ | ︙ | |||
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/clock.n.
| ︙ | ︙ | |||
947 948 949 950 951 952 953 | 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/dict.n.
| ︙ | ︙ | |||
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
|
| ︙ | ︙ |
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 | '\" '\" 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 |
| ︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 | 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. .PP An operand may be specified in any of the following ways: | > > > > > > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | 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: |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | .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 |
.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
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 | .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]
|
| ︙ | ︙ | |||
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 |
.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
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.
| > > | > | 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/fpclassify.n.
1 | '\" | | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" 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 |
| ︙ | ︙ |
Changes to doc/http.n.
1 2 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. | | | 1 2 3 4 5 6 7 8 9 10 | '\" '\" 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 |
| ︙ | ︙ | |||
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 |
| ︙ | ︙ | |||
321 322 323 324 325 326 327 | 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 |
| ︙ | ︙ | |||
547 548 549 550 551 552 553 554 555 556 557 558 559 560 | 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. |
| ︙ | ︙ | |||
662 663 664 665 666 667 668 | \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/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) |
| ︙ | ︙ |
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/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/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 | '\" '\" 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 |
| ︙ | ︙ | |||
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/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/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::setSyncMode\fR ?\fInewValue\fR? .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | 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 | | | | | | | | | | | | | | | | | | | | | | | 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 |
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::setSyncMode\fR ?\fInewValue\fR?
This command is used to get or set the "Sync Mode" of the Safe Base.
When an argument is supplied, the command returns an error if the argument
is not a boolean value, or if any Safe Base interpreters exist. Typically
the value will be set as part of initialization - boolean true for
"Sync Mode" on (the default), false for "Sync Mode" off. With "Sync Mode"
on, the Safe Base keeps each child interpreter's ::auto_path synchronized
with its access path. See the section \fBSYNC MODE\fR below for details.
.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.
When called with no arguments, it returns the currently installed script.
When called with one argument, an empty string, the currently installed
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 | .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 | | | | | | | 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 |
.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\-autoPath\fR \fIdirectoryList\fR
This option sets the list of directories in the safe interpreter's
::auto_path. The option is undefined if the Safe Base has "Sync Mode" on
- in that case the safe interpreter's ::auto_path is managed by the Safe
|
| ︙ | ︙ | |||
239 240 241 242 243 244 245 | \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 | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
\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:
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | 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, | | | | | 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 | 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). |
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | 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 | | | | | | | | | | | | | | | | | 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 | 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 to \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR 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), |
| ︙ | ︙ | |||
390 391 392 393 394 395 396 | safe::setSyncMode 0 .CE .RE .PP Use \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR to create an interpreter with the properties that you require. The simplest way is not to specify \fB\-accessPath\fR or \fB\-autoPath\fR, which means the safe | | | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
safe::setSyncMode 0
.CE
.RE
.PP
Use \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR to create an
interpreter with the properties that you require. The simplest way is not
to specify \fB\-accessPath\fR or \fB\-autoPath\fR, which means the safe
interpreter will use the same paths as the parent interpreter. However,
if \fB\-accessPath\fR is specified, then \fB\-autoPath\fR must also be
specified, or else it will be set to {}.
.PP
The value of \fB\-autoPath\fR will be that required to access tclIndex
and pkgIndex.txt files according to the same rules as an unsafe
interpreter (see pkg_mkIndex(n) and library(n)).
.PP
With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and
the Safe Base sets the child's ::auto_path to a tokenized form of the
access path. In addition to the directories present if "Safe Mode" is off,
the ::auto_path includes the numerous subdirectories and module paths
that belong to the access path.
.SH SYNC MODE
Before Tcl version 8.6.x, the Safe Base kept each safe interpreter's
::auto_path synchronized with a tokenized form of its access path.
Limitations of Tcl 8.4 and earlier made this feature necessary. This
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 | Base interpreters. .PP In either mode, the most convenient way to initialize a safe interpreter is to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the \fB\-accessPath\fR or \fB\-autoPath\fR options (or with the \fB\-accessPath\fR option set to the empty list), which will give the safe interpreter the same access as the | | | | | | | | 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 |
Base interpreters.
.PP
In either mode, the most convenient way to initialize a safe interpreter is
to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the
\fB\-accessPath\fR or \fB\-autoPath\fR options (or with the \fB\-accessPath\fR
option set to the
empty list), which will give the safe interpreter the same access as the
parent interpreter to packages, modules, and autoloader files. With
"Sync Mode" off, the Safe Base will set the value of \fB\-autoPath\fR to the
parent's ::auto_path, and will set the child's ::auto_path to a tokenized form
of the parent's ::auto_path.
.PP
With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty
list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or
\fB::safe::interpConfigure\fR, it will be tokenized and used as the safe
interpreter's ::auto_path. Any directories that do not also belong to the
access path cannot be tokenized and will be silently ignored. However, the
value of \fB\-autoPath\fR will remain as specified, and will be used to
re-tokenize the child's ::auto_path if \fB::safe::interpConfigure\fR is called
to change the value of \fB\-accessPath\fR.
.PP
With "Sync Mode" off, if the access path is reset to the values in the
parent interpreter by calling \fB::safe::interpConfigure\fR with arguments
\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the argument
\fB\-autoPath\fR is supplied to specify a different value.
.PP
With "Sync Mode" off, if a non-empty value of \fB\-accessPath\fR is supplied, the
safe interpreter's ::auto_path will be set to {} (by
\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR) or left unchanged
(by \fB::safe::interpConfigure\fR). If the same command specifies a new
value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR argument has
been processed.
Examples of use with "Sync Mode" off: any of these commands will set the
::auto_path to a tokenized form of its value in the parent interpreter:
.RS
.PP
.CS
safe::interpCreate foo
safe::interpCreate foo -accessPath {}
safe::interpInit bar
safe::interpInit bar -accessPath {}
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 |
/usr/local/TclHome/lib/tcl8.6/http1.0
/usr/local/TclHome/lib/tcl8.6/opt0.4
/usr/local/TclHome/lib/tcl8.6/msgs
/usr/local/TclHome/lib/tcl8.6/encoding
/usr/local/TclHome/lib
}
| | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
/usr/local/TclHome/lib/tcl8.6/http1.0
/usr/local/TclHome/lib/tcl8.6/opt0.4
/usr/local/TclHome/lib/tcl8.6/msgs
/usr/local/TclHome/lib/tcl8.6/encoding
/usr/local/TclHome/lib
}
# The child's ::auto_path must be given a suitable value:
safe::interpConfigure foo -autoPath {
/usr/local/TclHome/lib/tcl8.6
/usr/local/TclHome/lib
}
# The two commands can be combined:
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 | \fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's ::auto_path, and so any necessary change must be made by the script: .RS .PP .CS safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 | | | | | | | 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 | \fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's ::auto_path, and so any necessary change must be made by the script: .RS .PP .CS safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 lassign [safe::interpConfigure foo -autoPath] DUM childAutoPath lappend childAutoPath /usr/local/TclHome/lib/extras/Img1.4.11 safe::interpConfigure foo -autoPath $childAutoPath .CE .RE .TP .SH "SEE ALSO" interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n), tm(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/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/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 1190 |
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 Tcl 8.6
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 generic/regcomp.c.
| ︙ | ︙ | |||
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);
}
|
| ︙ | ︙ | |||
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/regexec.c.
| ︙ | ︙ | |||
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/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 |
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)
}
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
declare 170 {
int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
| | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
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)
}
|
| ︙ | ︙ |
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! * |
| ︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 |
* 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.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | * 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) | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | * 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__) |
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
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 {
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
* On failure, report error line.
*/
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
| | | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 |
* 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.
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 |
/* 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 */
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 |
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);
}
|
| ︙ | ︙ | |||
4265 4266 4267 4268 4269 4270 4271 |
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 {
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
680 681 682 683 684 685 686 |
}
if (commandTypeInit == 0) {
TclRegisterCommandTypeName(TclObjInterpProc, "proc");
TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
| | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
}
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");
}
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
#ifdef TCL_NO_DEPRECATED
iPtr->result = &tclEmptyString;
#else
iPtr->result = iPtr->resultSpace;
#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
| | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
#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));
|
| ︙ | ︙ | |||
792 793 794 795 796 797 798 |
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 */
|
| ︙ | ︙ | |||
859 860 861 862 863 864 865 |
iPtr->chanMsg = NULL;
/*
* TIP #285, Script cancellation support.
*/
| | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
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;
|
| ︙ | ︙ | |||
2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 |
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
| > > | 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 |
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
|
| ︙ | ︙ | |||
2984 2985 2986 2987 2988 2989 2990 |
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
| | | 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 |
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.
|
| ︙ | ︙ | |||
3370 3371 3372 3373 3374 3375 3376 |
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
| | | 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 |
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) {
|
| ︙ | ︙ | |||
3460 3461 3462 3463 3464 3465 3466 |
* 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.
*/
| | | 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 |
* 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]
*/
|
| ︙ | ︙ | |||
3492 3493 3494 3495 3496 3497 3498 |
* 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.
*/
| | | 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 |
* 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++;
|
| ︙ | ︙ | |||
3522 3523 3524 3525 3526 3527 3528 |
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
| | | 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 |
}
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);
|
| ︙ | ︙ | |||
3657 3658 3659 3660 3661 3662 3663 |
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
| | | 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 |
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) {
|
| ︙ | ︙ | |||
3788 3789 3790 3791 3792 3793 3794 | * just in case the caller passed flags that might cause behaviour * unrelated to script cancellation. */ TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* | | | 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 | * 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); /* |
| ︙ | ︙ | |||
4037 4038 4039 4040 4041 4042 4043 |
/*
* Return the result of the call.
*/
if (funcResult.type == TCL_INT) {
TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
| | | 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 |
/*
* 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;
}
|
| ︙ | ︙ | |||
4196 4197 4198 4199 4200 4201 4202 |
}
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_IncrRefCount(script);
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
| | | 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 |
}
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) */
|
| ︙ | ︙ | |||
4317 4318 4319 4320 4321 4322 4323 | /* *---------------------------------------------------------------------- * * Tcl_Canceled -- * * Check if the script in progress has been canceled, i.e., | | | 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 | /* *---------------------------------------------------------------------- * * 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 |
| ︙ | ︙ | |||
5210 5211 5212 5213 5214 5215 5216 |
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);
| | | 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 |
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);
|
| ︙ | ︙ | |||
5403 5404 5405 5406 5407 5408 5409 |
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
| | | 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 |
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
|
| ︙ | ︙ | |||
6456 6457 6458 6459 6460 6461 6462 | * 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 | | | 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 | * 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); |
| ︙ | ︙ | |||
7025 7026 7027 7028 7029 7030 7031 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
| | | 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 |
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]. */
|
| ︙ | ︙ | |||
7507 7508 7509 7510 7511 7512 7513 | * None. * *---------------------------------------------------------------------- */ static int ExprCeilFunc( | | | 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 |
* 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;
|
| ︙ | ︙ | |||
7547 7548 7549 7550 7551 7552 7553 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
| | | 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 |
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;
|
| ︙ | ︙ | |||
7587 7588 7589 7590 7591 7592 7593 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
| | | 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 |
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;
|
| ︙ | ︙ | |||
7693 7694 7695 7696 7697 7698 7699 |
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
| | | 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 |
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;
|
| ︙ | ︙ | |||
7861 7862 7863 7864 7865 7866 7867 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
| | | 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 |
}
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;
|
| ︙ | ︙ | |||
7960 7961 7962 7963 7964 7965 7966 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
| | | | 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 |
#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;
|
| ︙ | ︙ | |||
8008 8009 8010 8011 8012 8013 8014 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
| | | 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 |
}
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;
|
| ︙ | ︙ | |||
8064 8065 8066 8067 8068 8069 8070 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
| | | | 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 |
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;
|
| ︙ | ︙ | |||
8125 8126 8127 8128 8129 8130 8131 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
| | | | | 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 |
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;
|
| ︙ | ︙ | |||
8240 8241 8242 8243 8244 8245 8246 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
| | | 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 |
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;
|
| ︙ | ︙ | |||
8319 8320 8321 8322 8323 8324 8325 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
| | | 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 |
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. */
|
| ︙ | ︙ | |||
8508 8509 8510 8511 8512 8513 8514 | #error "unknown or unexpected TCL_FPCLASSIFY_MODE" #endif /* TCL_FPCLASSIFY_MODE */ #endif /* !fpclassify */ } static int ExprIsFiniteFunc( | | | 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 |
#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;
|
| ︙ | ︙ | |||
8539 8540 8541 8542 8543 8544 8545 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
| | | 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 |
}
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;
|
| ︙ | ︙ | |||
8569 8570 8571 8572 8573 8574 8575 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
| | | 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 |
}
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;
|
| ︙ | ︙ | |||
8599 8600 8601 8602 8603 8604 8605 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
| | | 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 |
}
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;
|
| ︙ | ︙ | |||
8629 8630 8631 8632 8633 8634 8635 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
| | | 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 |
}
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;
|
| ︙ | ︙ | |||
8659 8660 8661 8662 8663 8664 8665 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
| | | 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 |
}
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;
|
| ︙ | ︙ | |||
8700 8701 8702 8703 8704 8705 8706 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
| | | 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 |
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;
|
| ︙ | ︙ | |||
8785 8786 8787 8788 8789 8790 8791 |
tail--;
if (*tail == ':' && tail[-1] == ':') {
name = tail+1;
break;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| | | | 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 |
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
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
8809 8810 8811 8812 8813 8814 8815 | * The 'tcl-probe' DTrace probe is triggered (if it is enabled). * *---------------------------------------------------------------------- */ static int DTraceObjCmd( | | | 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 |
* 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;
|
| ︙ | ︙ | |||
9193 9194 9195 9196 9197 9198 9199 | * updated so that its data[1] field contains the tailcall list. * *---------------------------------------------------------------------- */ int TclNRTailcallObjCmd( | | | 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 |
* 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) {
|
| ︙ | ︙ | |||
9386 9387 9388 9389 9390 9391 9392 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
| | | 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 |
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);
|
| ︙ | ︙ | |||
9509 9510 9511 9512 9513 9514 9515 |
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
| | | 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 |
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);
|
| ︙ | ︙ | |||
9696 9697 9698 9699 9700 9701 9702 | * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ static int CoroTypeObjCmd( | | | 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 |
* 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;
|
| ︙ | ︙ | |||
9786 9787 9788 9789 9790 9791 9792 |
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
| | | 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 |
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;
|
| ︙ | ︙ | |||
9831 9832 9833 9834 9835 9836 9837 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
| | | 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 |
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;
|
| ︙ | ︙ | |||
9955 9956 9957 9958 9959 9960 9961 |
Tcl_ListObjAppendElement(NULL, listPtr,
Tcl_NewStringObj("yieldto", -1));
} else {
/*
* I don't think this is reachable...
*/
| | | 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 |
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.
*/
|
| ︙ | ︙ | |||
10024 10025 10026 10027 10028 10029 10030 | * Implementation of [::tcl::unsupported::inject] command. * *---------------------------------------------------------------------- */ static int NRInjectObjCmd( | | | 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 |
* 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;
|
| ︙ | ︙ | |||
10133 10134 10135 10136 10137 10138 10139 | * description of what this does. * *---------------------------------------------------------------------- */ int TclNRCoroutineObjCmd( | | | 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 |
* 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;
|
| ︙ | ︙ | |||
10266 10267 10268 10269 10270 10271 10272 | /* * This is used in the [info] ensemble */ int TclInfoCoroutineCmd( | | | | 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 |
/*
* 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.
| ︙ | ︙ | |||
270 271 272 273 274 275 276 |
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. */
| | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
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)
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
}
/*
* 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.
|
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
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) {
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 | } } 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--;
}
}
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
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;
|
| ︙ | ︙ | |||
1646 1647 1648 1649 1650 1651 1652 |
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 |
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;
|
| ︙ | ︙ | |||
1730 1731 1732 1733 1734 1735 1736 |
} 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;
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
| | > | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 |
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
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 |
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
| | | 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 |
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));
|
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 |
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
*/
| | | 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 |
}
/*
* 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;
|
| ︙ | ︙ |
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
| | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 |
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if defined(USE_TCLALLOC) && USE_TCLALLOC
TclFinalizeAllocSubsystem();
#endif
}
/*
* Local Variables:
* mode: c
|
| ︙ | ︙ |
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 | /* * 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 (c) 1991-1995 Karl Lehenbauer & Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * Copyright (c) 2004 by 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. */ |
| ︙ | ︙ | |||
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 |
{"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;
}
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | 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); | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | 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; |
| ︙ | ︙ | |||
2595 2596 2597 2598 2599 2600 2601 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
| | | 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 |
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[])
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
if (objc == 3) {
incrPtr = objv[2];
} else {
| | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
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) {
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
* 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);
| | | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 |
* 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);
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
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);
| | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
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);
|
| ︙ | ︙ | |||
965 966 967 968 969 970 971 |
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));
}
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
return TCL_ERROR;
}
target = interp;
if (objc == 2) {
| | | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
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);
|
| ︙ | ︙ | |||
1881 1882 1883 1884 1885 1886 1887 |
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto simpleProcOK;
}
} else {
simpleProcOK:
if (specificNsInPattern) {
| | | | | | 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 |
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);
}
}
|
| ︙ | ︙ | |||
2138 2139 2140 2141 2142 2143 2144 |
command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
TCL_LEAVE_ERR_MSG);
if (command == NULL) {
return TCL_ERROR;
}
/*
| | | 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 |
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 {
|
| ︙ | ︙ | |||
2213 2214 2215 2216 2217 2218 2219 |
(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.
|
| ︙ | ︙ | |||
3152 3153 3154 3155 3156 3157 3158 |
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 {
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 |
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 */
|
| ︙ | ︙ | |||
3509 3510 3511 3512 3513 3514 3515 |
* "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.
*/
|
| ︙ | ︙ | |||
3798 3799 3800 3801 3802 3803 3804 |
} 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...
*/
|
| ︙ | ︙ | |||
4410 4411 4412 4413 4414 4415 4416 |
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;
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 |
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
};
| | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
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:
|
| ︙ | ︙ | |||
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);
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
"-all", "-command", "-expanded", "-line",
"-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
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:
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 |
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 {
| | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 |
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
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 |
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
stringPtr = TclGetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
| | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
} 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;
|
| ︙ | ︙ | |||
1532 1533 1534 1535 1536 1537 1538 |
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
"list", "lower", "print", "punct",
"space", "true", "upper", "wideinteger",
"wordchar", "xdigit", NULL
};
| | | | 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 |
"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;
|
| ︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 |
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");
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
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:
|
| ︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 |
/*
* Only set the failVarObj when we will return 0 and we have indicated a
* valid fail index (>= 0).
*/
str_is_done:
| | | | | > | 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
/*
* 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(
|
| ︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 |
StringStartCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
| | | > | < | < | | | | | | | > | | 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 |
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 --
|
| ︙ | ︙ | |||
2565 2566 2567 2568 2569 2570 2571 |
StringEndCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
| | | > | < | < | | | | > | | 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 |
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 --
|
| ︙ | ︙ | |||
3475 3476 3477 3478 3479 3480 3481 |
* -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;
|
| ︙ | ︙ | |||
3766 3767 3768 3769 3770 3771 3772 |
}
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,
|
| ︙ | ︙ | |||
4161 4162 4163 4164 4165 4166 4167 |
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,
|
| ︙ | ︙ | |||
4538 4539 4540 4541 4542 4543 4544 |
* 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...
*/
|
| ︙ | ︙ | |||
4579 4580 4581 4582 4583 4584 4585 |
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. */
|
| ︙ | ︙ | |||
4617 4618 4619 4620 4621 4622 4623 |
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).
|
| ︙ | ︙ | |||
4710 4711 4712 4713 4714 4715 4716 |
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",
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
294 295 296 297 298 299 300 |
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.
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
/*
* 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.
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
}
/*
* 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);
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 |
}
/*
* 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;
}
|
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 |
/*
* 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 |
/*
* 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.
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 |
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
| | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
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(
|
| ︙ | ︙ | |||
2307 2308 2309 2310 2311 2312 2313 |
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
| | > | | 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
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);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2717 2718 2719 2720 2721 2722 2723 |
/*
* 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) {
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 |
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;
|
| ︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 |
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
| | | | 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 |
* 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;
}
|
| ︙ | ︙ | |||
3046 3047 3048 3049 3050 3051 3052 |
int i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Data stores.
*/
| | | | | | | | 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 |
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
|
| ︙ | ︙ | |||
3094 3095 3096 3097 3098 3099 3100 |
Tcl_Obj *objPtr, *innerPtr;
/*
* Jump offset.
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
| | | | | | 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 |
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);
}
/*
|
| ︙ | ︙ | |||
3159 3160 3161 3162 3163 3164 3165 |
}
/*
* 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;
}
}
/*
|
| ︙ | ︙ | |||
3262 3263 3264 3265 3266 3267 3268 |
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.
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
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;
}
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
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);
/*
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = parsePtr->numWords;
/*
| | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 |
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;
}
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 |
/*
* 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;
}
|
| ︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 |
/*
* 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"?
|
| ︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 |
*
* 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++) {
| | | 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 |
*
* 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--) {
|
| ︙ | ︙ | |||
2655 2656 2657 2658 2659 2660 2661 |
return TCL_ERROR;
}
/*
* Push the frame index if it is known at compile time
*/
| | | 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 |
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
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
/* 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++) {
| | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
/* 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;
}
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
/* 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 */
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
/* 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) {
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
"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);
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
* 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:
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
*/
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);
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 |
if (numArgs == 0) {
return TCL_ERROR;
}
objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
| | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
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);
}
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 |
DisassembleJumptableInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
| | | > | | 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 |
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);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3619 3620 3621 3622 3623 3624 3625 |
/*
* 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++) {
| | > | 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 |
/*
* 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
|
| ︙ | ︙ |
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 */ |
| ︙ | ︙ | |||
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,
|
| ︙ | ︙ | |||
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.
*/
|
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
2707 2708 2709 2710 2711 2712 2713 |
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
if (objc < 2) {
| | | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
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) {
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
844 845 846 847 848 849 850 |
* 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 |
* 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) {
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 |
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);
|
| ︙ | ︙ | |||
1830 1831 1832 1833 1834 1835 1836 |
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 |
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(
|
| ︙ | ︙ | |||
2031 2032 2033 2034 2035 2036 2037 |
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 |
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
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
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/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" |
| ︙ | ︙ | |||
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);
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 | Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, | | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | 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,
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 |
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 */
|
| ︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 |
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 */
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 | (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 \ |
| ︙ | ︙ | |||
2955 2956 2957 2958 2959 2960 2961 | (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 \ |
| ︙ | ︙ | |||
4179 4180 4181 4182 4183 4184 4185 4186 4187 | #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 #endif /* _TCLDECLS */ | > > > | 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 | #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.
| ︙ | ︙ | |||
2033 2034 2035 2036 2037 2038 2039 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
| | | 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 |
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2208 2209 2210 2211 2212 2213 2214 |
* 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);
|
| ︙ | ︙ |
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
"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,
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
*----------------------------------------------------------------------
*/
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;
}
/*
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
| | | | | 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 |
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));
|
| ︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 |
}
}
/*
* 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);
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | 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: |
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 |
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",
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 |
*/
#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;
}
|
| ︙ | ︙ |
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
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
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
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);
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
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 |
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);
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 |
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 |
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 =
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
} else {
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
*dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (*chPtr & 0xFF);
| | < < > > | 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 (*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
}
}
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
2905 2906 2907 2908 2909 2910 2911 |
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;
| | > | 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 |
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,
|
| ︙ | ︙ | |||
3257 3258 3259 3260 3261 3262 3263 |
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
| | | | | 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 |
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);
|
| ︙ | ︙ | |||
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/tclEvent.c.
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
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.
*/
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_VwaitObjCmd( | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
* 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;
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UpdateObjCmd( | | | | | 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 |
* 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 {
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
851 852 853 854 855 856 857 |
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));
| | | | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
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;
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
while (needed > newElems) {
newElems *= 2;
}
#else
newElems = needed;
#endif
| | | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
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;
|
| ︙ | ︙ | |||
3732 3733 3734 3735 3736 3737 3738 |
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;
|
| ︙ | ︙ | |||
4460 4461 4462 4463 4464 4465 4466 |
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;
|
| ︙ | ︙ | |||
4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 |
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.
|
| ︙ | ︙ | |||
4853 4854 4855 4856 4857 4858 4859 |
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;
}
|
| ︙ | ︙ | |||
5060 5061 5062 5063 5064 5065 5066 |
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) {
|
| ︙ | ︙ | |||
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 |
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;
}
|
| ︙ | ︙ | |||
5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 |
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) ||
|
| ︙ | ︙ | |||
5536 5537 5538 5539 5540 5541 5542 |
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);
| | | | 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 |
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,
|
| ︙ | ︙ | |||
6126 6127 6128 6129 6130 6131 6132 |
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;
|
| ︙ | ︙ | |||
6397 6398 6399 6400 6401 6402 6403 |
*/
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:
/*
|
| ︙ | ︙ | |||
6592 6593 6594 6595 6596 6597 6598 |
} 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 |
} 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;
|
| ︙ | ︙ | |||
7016 7017 7018 7019 7020 7021 7022 |
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 |
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);
}
|
| ︙ | ︙ | |||
7534 7535 7536 7537 7538 7539 7540 |
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);
|
| ︙ | ︙ | |||
9666 9667 9668 9669 9670 9671 9672 | * 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;
|
| ︙ | ︙ | |||
9689 9690 9691 9692 9693 9694 9695 |
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.
| ︙ | ︙ | |||
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;
}
/*
|
| ︙ | ︙ | |||
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);
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
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 |
}
/*
* 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];
|
| ︙ | ︙ | |||
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) {
|
| ︙ | ︙ | |||
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.
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
Tcl_Obj *typePtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
static const char *const options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
| | | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
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;
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 | */ 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];
|
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 |
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++;
|
| ︙ | ︙ |
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"
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
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);
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
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/tclIO.c.
| ︙ | ︙ | |||
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)) |
| ︙ | ︙ | |||
11126 11127 11128 11129 11130 11131 11132 |
*/
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];
| | | | 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 |
*/
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.
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
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.
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
}
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;
}
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
#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
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
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
};
| | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
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.
*/
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
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.
|
| ︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 | 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)); | | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 | 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); |
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
"-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
NULL
};
| | | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
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;
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
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;
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 |
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};
| | | | | | | | 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 |
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;
}
/*
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 |
if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) {
return TCL_ERROR;
}
channelNames[0] = Tcl_GetChannelName(rchan);
channelNames[1] = Tcl_GetChannelName(wchan);
| | | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
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;
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 |
}
#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) {
|
| ︙ | ︙ | |||
3048 3049 3050 3051 3052 3053 3054 |
case ForwardedInput: {
Tcl_Obj *toReadObj;
TclNewIntObj(toReadObj, paramPtr->input.toRead);
Tcl_IncrRefCount(toReadObj);
| | | 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 |
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);
|
| ︙ | ︙ | |||
3123 3124 3125 3126 3127 3128 3129 |
}
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.
|
| ︙ | ︙ |
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
1215 1216 1217 1218 1219 1220 1221 |
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) {
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
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;
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
* 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) {
|
| ︙ | ︙ | |||
1817 1818 1819 1820 1821 1822 1823 |
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;
|
| ︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 |
* 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) {
|
| ︙ | ︙ | |||
2693 2694 2695 2696 2697 2698 2699 | * 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 {
/*
|
| ︙ | ︙ | |||
3169 3170 3171 3172 3173 3174 3175 |
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) {
|
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 |
*---------------------------------------------------------------------------
*/
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) {
|
| ︙ | ︙ | |||
3828 3829 3830 3831 3832 3833 3834 |
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();
|
| ︙ | ︙ | |||
3899 3900 3901 3902 3903 3904 3905 |
/*
* 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.
|
| ︙ | ︙ | |||
4484 4485 4486 4487 4488 4489 4490 |
* 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) {
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
* 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 |
* 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).
*/
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
}
tablePtr[t] = Tcl_GetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
| | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
}
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;
}
/*
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
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 |
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;
}
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
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 |
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));
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
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
};
| | | | 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 |
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));
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
}
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;
|
| ︙ | ︙ |
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. |
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
921 922 923 924 925 926 927 928 929 930 931 932 933 934 | /* *---------------------------------------------------------------- * 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; |
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
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;
/*
|
| ︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 |
*/
#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;
|
| ︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 |
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
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 |
* 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 |
* 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
|
| ︙ | ︙ | |||
2601 2602 2603 2604 2605 2606 2607 |
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;
|
| ︙ | ︙ | |||
3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 | 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 TclUCS4Complete Tcl_UtfCharComplete # define TclChar16Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \ ? ((length) >= 3) : Tcl_UtfCharComplete((src), (length))) #else | > | | > | 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
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,
|
| ︙ | ︙ | |||
4171 4172 4173 4174 4175 4176 4177 | /* * 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. |
| ︙ | ︙ | |||
4517 4518 4519 4520 4521 4522 4523 | * 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 |
* 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.
*/
|
| ︙ | ︙ | |||
4549 4550 4551 4552 4553 4554 4555 | * string representation (or is a 'pure' internal value). * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ | | > | 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 |
* 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:
*
|
| ︙ | ︙ | |||
4931 4932 4933 4934 4935 4936 4937 | #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 |
| ︙ | ︙ | |||
4956 4957 4958 4959 4960 4961 4962 | /* *---------------------------------------------------------------- * 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)
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 1415 1416 | # 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.
| ︙ | ︙ | |||
598 599 600 601 602 603 604 | # define TclWinSetSockOpt setsockopt # define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ # define TclWinResetInterfaces() /* nop */ # define TclWinSetInterfaces(dummy) /* nop */ # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid | | | 598 599 600 601 602 603 604 605 606 607 608 | # 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.
| ︙ | ︙ | |||
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 -- * |
| ︙ | ︙ | |||
457 458 459 460 461 462 463 | } /* *--------------------------------------------------------------------------- * * 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 |
}
/*
*---------------------------------------------------------------------------
*
* 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);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
| | | | > > > > > > > > > | < | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | 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 |
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;
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
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
};
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
}
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 |
}
}
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;
|
| ︙ | ︙ | |||
1163 1164 1165 1166 1167 1168 1169 | * * 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * 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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 |
{
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 |
{
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);
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
{
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 |
{
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);
|
| ︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 |
/*
* 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)) {
/*
| | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
/*
* 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;
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 | * 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 | | | | | | | | | | | | | | | | | | | | | 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 |
* 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
|
| ︙ | ︙ | |||
1618 1619 1620 1621 1622 1623 1624 |
*
* 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));
| | | | | | | | | | | | | | | | | | | 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 |
*
* 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 --
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 |
*
*----------------------------------------------------------------------
*/
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.
*
|
| ︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 | } /* *---------------------------------------------------------------------- * * AliasObjCmdDeleteProc -- * | | | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 | } /* *---------------------------------------------------------------------- * * 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 |
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
/*
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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:
|
| ︙ | ︙ | |||
2182 2183 2184 2185 2186 2187 2188 |
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. */
{
| | | | | | | | | | 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 |
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
|
| ︙ | ︙ | |||
2259 2260 2261 2262 2263 2264 2265 |
Tcl_SetObjResult(interp, Tcl_NewObj());
return TCL_OK;
}
if (targetInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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
};
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 |
}
}
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 {
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 |
}
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",
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
}
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) {
|
| ︙ | ︙ | |||
2988 2989 2990 2991 2992 2993 2994 |
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 --
|
| ︙ | ︙ | |||
3257 3258 3259 3260 3261 3262 3263 |
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
*/
|
| ︙ | ︙ | |||
4182 4183 4184 4185 4186 4187 4188 | /* *---------------------------------------------------------------------- * * 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 | /* *---------------------------------------------------------------------- * * 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. |
| ︙ | ︙ | |||
4395 4396 4397 4398 4399 4400 4401 |
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
};
|
| ︙ | ︙ | |||
4478 4479 4480 4481 4482 4483 4484 |
/*
* 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;
|
| ︙ | ︙ | |||
4604 4605 4606 4607 4608 4609 4610 |
"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
};
|
| ︙ | ︙ | |||
4666 4667 4668 4669 4670 4671 4672 |
/*
* 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;
|
| ︙ | ︙ | |||
4725 4726 4727 4728 4729 4730 4731 |
} 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:
|
| ︙ | ︙ | |||
4866 4867 4868 4869 4870 4871 4872 | * 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.
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 | TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); return resultObj; } linkPtr->lastValue.i = LinkedVar(int); | | | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 |
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);
|
| ︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 | TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); return resultObj; } linkPtr->lastValue.c = LinkedVar(char); | | | | | | | | | 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 |
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);
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
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++) {
| | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
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.
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
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]);
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
while (++i < indexCount) {
if (TclGetIntForIndexM(interp, indexArray[i], INT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
| | | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 |
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];
}
|
| ︙ | ︙ | |||
1619 1620 1621 1622 1623 1624 1625 |
* take steps to make sure it is an unshared copy, as we intend to
* modify it.
*/
if (--indexCount) {
parentList = subListPtr;
if (index == elemCount) {
| | | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 |
* 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);
}
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
| ︙ | ︙ | |||
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;
}
}
/*
|
| ︙ | ︙ | |||
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 |
/*
* 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__ */
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.
*/
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd( | | | | 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 |
* 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; } } | | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
* 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) {
| | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
/*
* 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
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 |
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
}
/*
*----------------------------------------------------------------------
*
| | < < < < < < < < < < < < | | | 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 |
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.
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
}
/*
* Return information about only the packages that are loaded in a given
* interpreter.
*/
| | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
}
/*
* 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);
|
| ︙ | ︙ |
Changes to generic/tclLoadNone.c.
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
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);
}
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
* 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);
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 | } dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; 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. | > > | 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 | } 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. |
| ︙ | ︙ | |||
2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 |
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
ckfree(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
| > | 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
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");
|
| ︙ | ︙ | |||
3539 3540 3541 3542 3543 3544 3545 |
/*
* If no pattern arguments are given, and "-clear" isn't specified, return
* the namespace's current export pattern list.
*/
if (objc == 1) {
| | > | | 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 |
/*
* 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.
*/
|
| ︙ | ︙ | |||
3884 3885 3886 3887 3888 3889 3890 |
static int
NamespaceOriginCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | > > > > > > > > > > > < < < < < < < < < < < < < > | 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 |
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
|
| ︙ | ︙ | |||
4018 4019 4020 4021 4022 4023 4024 |
}
/*
* If no path is given, return the current path.
*/
if (objc == 1) {
| | > | 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 |
}
/*
* 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);
|
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 |
*/
} 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/tclOO.c.
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
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 |
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 =
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
| | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
*/
if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
(void *) &tclOOStubs);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetFoundation --
*
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 | * when the objects and classes themselves are destroyed. * * ---------------------------------------------------------------------- */ static void KillFoundation( | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
* 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);
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
/*
* 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.
*/
| | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
/*
* 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
|
| ︙ | ︙ | |||
3031 3032 3033 3034 3035 3036 3037 |
Object *oPtr)
{
Tcl_Obj *namePtr;
if (oPtr->cachedNameObj) {
return oPtr->cachedNameObj;
}
| | | 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
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.
| ︙ | ︙ | |||
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!
*/
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
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]);
|
| ︙ | ︙ | |||
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 |
} 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;
}
|
| ︙ | ︙ | |||
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 |
} 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;
|
| ︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 |
} 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;
}
| | | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 |
} 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;
}
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
} 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;
}
| | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 |
} 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 {
|
| ︙ | ︙ | |||
2796 2797 2798 2799 2800 2801 2802 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
| | | 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 |
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;
}
|
| ︙ | ︙ | |||
2865 2866 2867 2868 2869 2870 2871 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
| | | 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 |
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);
|
| ︙ | ︙ | |||
2950 2951 2952 2953 2954 2955 2956 |
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
} else if (oPtr == NULL) {
return TCL_ERROR;
}
| | | 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 |
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 {
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
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;
}
| | | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
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);
}
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | * Implements [info object filters $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectFiltersCmd( | | | | | 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 |
* 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;
|
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 |
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;
}
| | | | 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 |
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);
}
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 | * Implements [info class definitionnamespace $clsName ?$kind?] * * ---------------------------------------------------------------------- */ static int InfoClassDefnNsCmd( | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
* 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;
|
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
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
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
390 391 392 393 394 395 396 |
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 |
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));
}
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
/*
* Copy the argument list.
*/
| | | > | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
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);
}
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
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);
|
| ︙ | ︙ | |||
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
|
| ︙ | ︙ | |||
4663 4664 4665 4666 4667 4668 4669 |
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 |
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.
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
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 |
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,
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 |
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;
|
| ︙ | ︙ | |||
931 932 933 934 935 936 937 | /* * 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) {
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 |
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
|
| ︙ | ︙ | |||
2392 2393 2394 2395 2396 2397 2398 | * * 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.
| ︙ | ︙ | |||
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 |
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;
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
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",
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
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) {
| | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
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));
}
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
"files", "forget", "ifneeded", "names", "prefer",
"present", "provide", "require", "unknown", "vcompare",
"versions", "vsatisfies", NULL
};
| | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 |
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;
}
|
| ︙ | ︙ | |||
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 |
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));
|
| ︙ | ︙ | |||
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 |
}
/*
* 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,
|
| ︙ | ︙ |
Changes to generic/tclPkgConfig.c.
| ︙ | ︙ | |||
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/tclProc.c.
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
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;
|
| ︙ | ︙ | |||
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 |
CmdFrame *invoker = NULL;
int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
Tcl_Obj *objPtr;
if (objc < 2) {
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
}
/*
* 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;
/*
* Modify the interpreter state to execute in the given frame.
*/
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
| > > > > > > > > > > > > > > > > > > > > > | 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 |
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;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
/*
* 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)) {
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
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) {
/*
|
| ︙ | ︙ | |||
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 |
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);
|
| ︙ | ︙ | |||
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;
}
/*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
int result;
int i;
int pid;
Tcl_Obj *const *savedobjv = objv;
static const char *const switches[] = {
"-wait", "--", NULL
};
| | | | 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 |
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;
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
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.
| ︙ | ︙ | |||
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++) {
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
*/
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;
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
*/
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));
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
* -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;
|
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 |
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.
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
/*
* 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;
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUCS4(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
| | | | 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 |
/*
* 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);
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
}
} 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",
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 |
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.
| ︙ | ︙ | |||
2981 2982 2983 2984 2985 2986 2987 |
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;
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
2129 2130 2131 2132 2133 2134 2135 |
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);
|
| ︙ | ︙ | |||
2174 2175 2176 2177 2178 2179 2180 |
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.
*/
|
| ︙ | ︙ | |||
2304 2305 2306 2307 2308 2309 2310 |
/*
* 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)) {
|
| ︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 | /* * 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));
|
| ︙ | ︙ | |||
2539 2540 2541 2542 2543 2544 2545 |
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;
}
|
| ︙ | ︙ | |||
2568 2569 2570 2571 2572 2573 2574 |
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++ != '%') {
|
| ︙ | ︙ | |||
2784 2785 2786 2787 2788 2789 2790 |
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;
}
/*
|
| ︙ | ︙ | |||
3310 3311 3312 3313 3314 3315 3316 |
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);
|
| ︙ | ︙ | |||
3406 3407 3408 3409 3410 3411 3412 |
* 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)) {
|
| ︙ | ︙ | |||
3431 3432 3433 3434 3435 3436 3437 |
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)) {
|
| ︙ | ︙ | |||
3489 3490 3491 3492 3493 3494 3495 |
* 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) {
|
| ︙ | ︙ | |||
3557 3558 3559 3560 3561 3562 3563 |
Tcl_Obj *needle,
Tcl_Obj *haystack,
int start)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
| | | 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 |
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
|
| ︙ | ︙ | |||
3623 3624 3625 3626 3627 3628 3629 |
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;
}
| | | | | | | 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 |
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;
}
|
| ︙ | ︙ | |||
3664 3665 3666 3667 3668 3669 3670 |
Tcl_Obj *needle,
Tcl_Obj *haystack,
int last)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
| | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 |
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.
|
| ︙ | ︙ | |||
3710 3711 3712 3713 3714 3715 3716 |
if (last >= lh) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
| | | | | | | | 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 |
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;
}
/*
|
| ︙ | ︙ | |||
3826 3827 3828 3829 3830 3831 3832 |
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
|
| ︙ | ︙ |
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/tclStubInit.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 | #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 #undef Tcl_MacOSXOpenBundleResources #if TCL_UTF_MAX > 3 | > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #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 |
| ︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
# 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
#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;
}
| > > > > > > > > > > > > > > > > > > > > | 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 |
# 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;
}
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 |
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
int
TclpGetPid(Tcl_Pid pid)
{
| | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
(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,
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 |
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 */
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
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/tclTest.c.
| ︙ | ︙ | |||
723 724 725 726 727 728 729 | * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ static int TestasyncCmd( | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 |
* 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;
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
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 |
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) {
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 | * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ static int TestcmdinfoCmd( | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 |
* 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) {
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 | * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ static int TestcmdtokenCmd( | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
* 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];
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | * a procedure by the command trace. * *---------------------------------------------------------------------- */ static int TestcmdtraceCmd( | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* 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;
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
* 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*/,
| | | | | | 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 |
* 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. */
{
|
| ︙ | ︙ | |||
1350 1351 1352 1353 1354 1355 1356 | * 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);
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
| | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 |
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;
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 |
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
| | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
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;
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 | * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ static int TestdcallCmd( | | | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
* 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();
|
| ︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 | * Creates a command. * *---------------------------------------------------------------------- */ static int TestdelCmd( | | | | | | | 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 |
* 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. */
|
| ︙ | ︙ | |||
1579 1580 1581 1582 1583 1584 1585 | * 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);
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 | * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int TestdoubledigitsObjCmd( | | | 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 |
* 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",
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 | * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ static int TestdstringCmd( | | | 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 |
* 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) {
|
| ︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | * Load encodings. * *---------------------------------------------------------------------- */ static int TestencodingObjCmd( | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 |
* 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;
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 | * 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;
|
| ︙ | ︙ | |||
2034 2035 2036 2037 2038 2039 2040 | * 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) {
|
| ︙ | ︙ | |||
2083 2084 2085 2086 2087 2088 2089 | * 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
};
|
| ︙ | ︙ | |||
2262 2263 2264 2265 2266 2267 2268 | * 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) {
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 | * 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;
|
| ︙ | ︙ | |||
2381 2382 2383 2384 2385 2386 2387 | * 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;
|
| ︙ | ︙ | |||
2423 2424 2425 2426 2427 2428 2429 | * 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;
|
| ︙ | ︙ | |||
2467 2468 2469 2470 2471 2472 2473 | * 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;
|
| ︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 | * 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);
|
| ︙ | ︙ | |||
2541 2542 2543 2544 2545 2546 2547 | * 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) {
|
| ︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 | * 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) {
|
| ︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | * 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;
|
| ︙ | ︙ | |||
2686 2687 2688 2689 2690 2691 2692 | * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ static int TestinterpdeleteCmd( | | | | | | | 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 |
* 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 --
|
| ︙ | ︙ | |||
2726 2727 2728 2729 2730 2731 2732 | * values of the linked variables. * *---------------------------------------------------------------------- */ static int TestlinkCmd( | | | 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 |
* 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;
|
| ︙ | ︙ | |||
3194 3195 3196 3197 3198 3199 3200 | * 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,
|
| ︙ | ︙ | |||
3227 3228 3229 3230 3231 3232 3233 |
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++) {
|
| ︙ | ︙ | |||
3312 3313 3314 3315 3316 3317 3318 | * Modifies the current C locale. * *---------------------------------------------------------------------- */ static int TestlocaleCmd( | | | 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 |
* 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[] = {
|
| ︙ | ︙ | |||
3398 3399 3400 3401 3402 3403 3404 | * 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;
|
| ︙ | ︙ | |||
3454 3455 3456 3457 3458 3459 3460 | * 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;
|
| ︙ | ︙ | |||
3601 3602 3603 3604 3605 3606 3607 | * 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) {
|
| ︙ | ︙ | |||
3642 3643 3644 3645 3646 3647 3648 | * 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;
|
| ︙ | ︙ | |||
3705 3706 3707 3708 3709 3710 3711 | * None. * *---------------------------------------------------------------------- */ static int TestpreferstableObjCmd( | | | 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 |
* 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;
|
| ︙ | ︙ | |||
3735 3736 3737 3738 3739 3740 3741 | * 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;
|
| ︙ | ︙ | |||
3776 3777 3778 3779 3780 3781 3782 | * See the user documentation. * *---------------------------------------------------------------------- */ static int TestregexpObjCmd( | | | | 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 |
* 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;
|
| ︙ | ︙ | |||
3818 3819 3820 3821 3822 3823 3824 |
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:
|
| ︙ | ︙ | |||
4099 4100 4101 4102 4103 4104 4105 | * See the user documentation. * *---------------------------------------------------------------------- */ static int TestreturnObjCmd( | | | 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 |
* 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;
}
|
| ︙ | ︙ | |||
4127 4128 4129 4130 4131 4132 4133 | * data for this interpreter. * *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( | | | 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 |
* 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;
|
| ︙ | ︙ | |||
4178 4179 4180 4181 4182 4183 4184 | * 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;
|
| ︙ | ︙ | |||
4227 4228 4229 4230 4231 4232 4233 | * 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) {
|
| ︙ | ︙ | |||
4278 4279 4280 4281 4282 4283 4284 | * 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;
|
| ︙ | ︙ | |||
4319 4320 4321 4322 4323 4324 4325 | * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ static int TestupvarCmd( | | | 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 |
* 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)) {
|
| ︙ | ︙ | |||
4371 4372 4373 4374 4375 4376 4377 | * None. * *---------------------------------------------------------------------- */ static int TestseterrorcodeCmd( | | | 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 |
* 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;
|
| ︙ | ︙ | |||
4423 4424 4425 4426 4427 4428 4429 | * None. * *---------------------------------------------------------------------- */ static int TestsetobjerrorcodeCmd( | | | 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 |
* 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;
}
|
| ︙ | ︙ | |||
4451 4452 4453 4454 4455 4456 4457 | * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ static int TestfeventCmd( | | | 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 |
* 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;
|
| ︙ | ︙ | |||
4523 4524 4525 4526 4527 4528 4529 | * 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;
|
| ︙ | ︙ | |||
4624 4625 4626 4627 4628 4629 4630 | * 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;
|
| ︙ | ︙ | |||
4698 4699 4700 4701 4702 4703 4704 | * 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 |
* 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;
|
| ︙ | ︙ | |||
4877 4878 4879 4880 4881 4882 4883 | * None. * *---------------------------------------------------------------------- */ static int NoopCmd( | | | 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4904 4905 4906 4907 4908 4909 4910 | * None. * *---------------------------------------------------------------------- */ static int NoopObjCmd( | | | 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
|
| ︙ | ︙ | |||
4929 4930 4931 4932 4933 4934 4935 | * 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;
|
| ︙ | ︙ | |||
4969 4970 4971 4972 4973 4974 4975 | * None. * *---------------------------------------------------------------------- */ static int TestpurebytesobjObjCmd( | | | 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 |
* 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) {
|
| ︙ | ︙ | |||
5016 5017 5018 5019 5020 5021 5022 | * None. * *---------------------------------------------------------------------- */ static int TestsetbytearraylengthObjCmd( | | | 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 |
* 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;
|
| ︙ | ︙ | |||
5060 5061 5062 5063 5064 5065 5066 | * None. * *---------------------------------------------------------------------- */ static int TestbytestringObjCmd( | | | 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 |
* 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;
|
| ︙ | ︙ | |||
5182 5183 5184 5185 5186 5187 5188 | * None. * *---------------------------------------------------------------------- */ static int TestsaveresultCmd( | | | 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 |
* 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;
|
| ︙ | ︙ | |||
5313 5314 5315 5316 5317 5318 5319 | * None. * *---------------------------------------------------------------------- */ static int TestmainthreadCmd( | | | 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 |
* 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());
|
| ︙ | ︙ | |||
5374 5375 5376 5377 5378 5379 5380 | * None. * *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( | | | 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 |
* 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;
|
| ︙ | ︙ | |||
5403 5404 5405 5406 5407 5408 5409 | * None. * *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( | | | 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 |
* 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;
}
|
| ︙ | ︙ | |||
5431 5432 5433 5434 5435 5436 5437 | * None. * *---------------------------------------------------------------------- */ static int TestChannelCmd( | | | 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 |
* 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. */
|
| ︙ | ︙ | |||
5898 5899 5900 5901 5902 5903 5904 | * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ static int TestChannelEventCmd( | | | 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 |
* 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 */
|
| ︙ | ︙ | |||
6110 6111 6112 6113 6114 6115 6116 | * None. * *---------------------------------------------------------------------- */ static int TestSocketCmd( | | | 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 |
* 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. */
|
| ︙ | ︙ | |||
6181 6182 6183 6184 6185 6186 6187 | * May change the ServiceMode setting. * *---------------------------------------------------------------------- */ static int TestServiceModeCmd( | | | 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 |
* 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],
|
| ︙ | ︙ | |||
6225 6226 6227 6228 6229 6230 6231 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( | | | 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 |
* 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;
|
| ︙ | ︙ | |||
6281 6282 6283 6284 6285 6286 6287 | * 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
};
|
| ︙ | ︙ | |||
6335 6336 6337 6338 6339 6340 6341 | * 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;
|
| ︙ | ︙ | |||
6677 6678 6679 6680 6681 6682 6683 |
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
| | | 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 |
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;
|
| ︙ | ︙ | |||
6706 6707 6708 6709 6710 6711 6712 | * 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;
|
| ︙ | ︙ | |||
6910 6911 6912 6913 6914 6915 6916 |
}
}
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) {
| > > | | | 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 |
}
}
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;
}
|
| ︙ | ︙ | |||
6967 6968 6969 6970 6971 6972 6973 | /* * Used to check correct string-length determining in Tcl_NumUtfChars */ static int TestNumUtfCharsCmd( | | | 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 |
/*
* 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);
|
| ︙ | ︙ | |||
6996 6997 6998 6999 7000 7001 7002 | /* * Used to check correct operation of Tcl_UtfFindFirst */ static int TestFindFirstCmd( | | | 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 |
/*
* 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;
|
| ︙ | ︙ | |||
7018 7019 7020 7021 7022 7023 7024 | /* * 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;
|
| ︙ | ︙ | |||
7060 7061 7062 7063 7064 7065 7066 | * 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];
|
| ︙ | ︙ | |||
7096 7097 7098 7099 7100 7101 7102 | /* * 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
|
| ︙ | ︙ | |||
7172 7173 7174 7175 7176 7177 7178 | /* * 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;
|
| ︙ | ︙ | |||
7199 7200 7201 7202 7203 7204 7205 | } /* * 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 |
}
/*
* 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;
|
| ︙ | ︙ | |||
7241 7242 7243 7244 7245 7246 7247 |
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 |
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;
|
| ︙ | ︙ | |||
7315 7316 7317 7318 7319 7320 7321 | * None. * *---------------------------------------------------------------------- */ static int TestconcatobjCmd( | | | 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 |
* 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];
|
| ︙ | ︙ | |||
7484 7485 7486 7487 7488 7489 7490 |
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:
|
| ︙ | ︙ | |||
7516 7517 7518 7519 7520 7521 7522 |
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:
|
| ︙ | ︙ | |||
7549 7550 7551 7552 7553 7554 7555 |
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:
|
| ︙ | ︙ | |||
7611 7612 7613 7614 7615 7616 7617 | * 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;
|
| ︙ | ︙ | |||
7644 7645 7646 7647 7648 7649 7650 | * 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;
|
| ︙ | ︙ | |||
7678 7679 7680 7681 7682 7683 7684 | * 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];
|
| ︙ | ︙ | |||
7917 7918 7919 7920 7921 7922 7923 |
return TCL_OK;
}
return TCL_CONTINUE;
}
static int
TestInterpResolverCmd(
| | | | 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 |
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.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | * 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
};
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 | * 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;
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 | * 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;
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 | * have int type. * *---------------------------------------------------------------------- */ static int TestindexobjCmd( | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
* 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};
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
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],
| | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
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;
}
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 | * 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;
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 | * 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",
|
| ︙ | ︙ | |||
953 954 955 956 957 958 959 | * 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;
|
| ︙ | ︙ | |||
1165 1166 1167 1168 1169 1170 1171 | * 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
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
| ︙ | ︙ | |||
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;
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 | * Returns a standard Tcl code. * *---------------------------------------------------------------------- */ static int ProcBodyTestCheckObjCmd( | | | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
* 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/tclThreadTest.c.
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | * See the user documentation. * *---------------------------------------------------------------------- */ static int ThreadObjCmd( | | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
* 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[] = {
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
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 |
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.
*/
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
TCL_UNUSED(void *))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
| | | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
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;
}
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
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) {
| | > | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
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));
}
}
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
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;
|
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
179 180 181 182 183 184 185 | * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ int Tcl_TraceObjCmd( | | | | | 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 |
* 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.
*/
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
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++) {
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
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 |
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) {
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
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 |
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
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
* 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;
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
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++;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 |
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)) {
| | > > > > > > > > > > > > > | 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 |
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
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
2036 2037 2038 2039 2040 2041 2042 |
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
|
| ︙ | ︙ | |||
3753 3754 3755 3756 3757 3758 3759 |
Tcl_ObjIntRep ir;
int length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
| | | | 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 |
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;
}
|
| ︙ | ︙ | |||
3813 3814 3815 3816 3817 3818 3819 |
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 == '-') {
| | | 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 |
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 */
|
| ︙ | ︙ | |||
3835 3836 3837 3838 3839 3840 3841 |
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
| < < < < < < < > | > > > > > | 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 |
} 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 */
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
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.
*/
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
/*
* 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;
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
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));
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
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;
}
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
if (tablePtr != NULL) {
varPtr = VarHashFindVar(tablePtr, varNamePtr);
}
if (varPtr == NULL) {
| | | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 |
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
if (tablePtr != NULL) {
varPtr = VarHashFindVar(tablePtr, varNamePtr);
}
if (varPtr == NULL) {
*errMsgPtr = NOSUCHVAR;
}
}
}
return varPtr;
}
/*
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 |
* 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;
}
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
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;
}
|
| ︙ | ︙ | |||
1481 1482 1483 1484 1485 1486 1487 |
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.
|
| ︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 |
* 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
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
/*
* 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
|
| ︙ | ︙ | |||
3913 3914 3915 3916 3917 3918 3919 |
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-exact", "-glob", "-regexp", NULL
};
| | | 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 |
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)) {
|
| ︙ | ︙ | |||
3981 3982 3983 3984 3985 3986 3987 |
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);
|
| ︙ | ︙ | |||
4100 4101 4102 4103 4104 4105 4106 |
/*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.
|
| ︙ | ︙ | |||
4219 4220 4221 4222 4223 4224 4225 |
}
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;
}
|
| ︙ | ︙ | |||
4282 4283 4284 4285 4286 4287 4288 |
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 --
|
| ︙ | ︙ | |||
5120 5121 5122 5123 5124 5125 5126 |
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;
}
|
| ︙ | ︙ | |||
5447 5448 5449 5450 5451 5452 5453 |
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 |
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);
/*
|
| ︙ | ︙ | |||
6116 6117 6118 6119 6120 6121 6122 |
*/
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);
}
|
| ︙ | ︙ | |||
6149 6150 6151 6152 6153 6154 6155 |
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);
}
|
| ︙ | ︙ | |||
6630 6631 6632 6633 6634 6635 6636 |
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
};
| | | 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 |
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.
*/
|
| ︙ | ︙ | |||
6654 6655 6656 6657 6658 6659 6660 |
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);
|
| ︙ | ︙ | |||
6697 6698 6699 6700 6701 6702 6703 |
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);
}
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
3234 3235 3236 3237 3238 3239 3240 |
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
if (!Tcl_IsSafe(interp)) {
Tcl_Obj *pResult = TclZipfs_TclLibrary();
if (!pResult) {
| | | 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 |
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;
}
/*
|
| ︙ | ︙ | |||
4481 4482 4483 4484 4485 4486 4487 |
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);
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
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!
*/
|
| ︙ | ︙ | |||
2158 2159 2160 2161 2162 2163 2164 |
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);
|
| ︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 |
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 |
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;
}
|
| ︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 |
}
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:
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 |
if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum addOptions) index) {
case ao_flush: /* -flush */
| | | | | 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 |
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) {
|
| ︙ | ︙ | |||
2826 2827 2828 2829 2830 2831 2832 |
if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum putOptions) index) {
case po_flush: /* -flush */
| | | | | 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 |
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) {
|
| ︙ | ︙ | |||
3480 3481 3482 3483 3484 3485 3486 |
/*
* 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);
|
| ︙ | ︙ | |||
3940 3941 3942 3943 3944 3945 3946 |
* 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 |
* 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");
|
| ︙ | ︙ |
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 -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 -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 -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 -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
|
| ︙ | ︙ |
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"
|
| ︙ | ︙ |
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 |
# 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
|
| ︙ | ︙ |
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] Dde]
|
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)
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 |
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-strict boolean
-timeout integer
-validate boolean
}
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
| > < | | | 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 |
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 {
|
| ︙ | ︙ | |||
2787 2788 2789 2790 2791 2792 2793 |
# 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.
| | | 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 |
# 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.
|
| ︙ | ︙ | |||
3240 3241 3242 3243 3244 3245 3246 |
# 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 | # 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. # |
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
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
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
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]} {
|
| ︙ | ︙ | |||
438 439 440 441 442 443 444 445 446 447 448 449 450 451 |
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 -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)} {
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
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 -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 -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 -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 {}
}
|
| ︙ | ︙ |
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 |
###
# 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.14 {platform platform.tcl}
0 platform::shell 1.1.4 {platform shell.tcl}
1 tcltest 2.5.3 {tcltest tcltest.tcl}
} {
if {$isafe && !$safe} continue
|
| ︙ | ︙ |
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 | # 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, |
| ︙ | ︙ |
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 -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
|
| ︙ | ︙ |
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/reg/pkgIndex.tcl.
1 2 3 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded registry 1.3.5 \
| | | 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 tclreg13.dll] Registry]
|
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
}
|
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
variable AutoPathSync
if {$AutoPathSync} {
set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
| | | | | | | | | | | | | 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 |
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
variable AutoPathSync
if {$AutoPathSync} {
set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
RejectExcessColons $child
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
InterpCreate $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}
proc ::safe::interpInit {args} {
variable AutoPathSync
if {$AutoPathSync} {
set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $child]} {
return -code error "\"$child\" is not an interpreter"
}
RejectExcessColons $child
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
InterpInit $child $accessPath \
[InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}
# 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
|
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
variable AutoPathSync
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
| | | | | | | | 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 |
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
variable AutoPathSync
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
set TMP [list \
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
[list -deleteHook $state(cleanupHook)] \
]
if {!$AutoPathSync} {
lappend TMP [list -autoPath $state(auto_path)]
}
return [join $TMP]
}
2 {
# If we have exactly 2 arguments the semantic is a "configure
# get"
lassign $args child arg
# 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)]
}
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
}
}
}
default {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
| | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
}
}
}
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 {
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set nested $state(nestedok)
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
# we can now reconfigure :
set withAutoPath [::tcl::OptProcArgGiven -autoPath]
InterpSetConfig $child $accessPath $statics $nested $deleteHook $autoPath $withAutoPath
# auto_reset the child (to completely synch the new access_path) tests safe-9.8 safe-9.9
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 and its subdirectories 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
autoPath
withAutoPath
} {
# 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 $autoPath $withAutoPath
}
#
# InterpSetConfig (was setAccessPath) :
# Sets up child virtual access 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.
#
# It is the caller's responsibility, if it supplies a non-empty value for
# access_path, to make the first directory in the path suitable for use as
# tcl_library, and (if ![setSyncMode]), to set the child's ::auto_path.
proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook autoPath withAutoPath} {
global auto_path
variable AutoPathSync
# 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
}
set raw_auto_path $access_path
# 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]
} else {
set raw_auto_path $autoPath
}
if {$withAutoPath} {
set raw_auto_path $autoPath
}
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
if {!$AutoPathSync} {
Log $child "Setting auto_path=($raw_auto_path)" NOTICE
}
namespace upvar ::safe [VarName $child] state
# clear old autopath if it existed
# build new one
# Extend the access list with the paths used to look for Tcl Modules.
# 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 the child auto_path to a tokenized raw_auto_path.
# Silently ignore any directories that are not in the access path.
# If [setSyncMode], SyncAccessPath will overwrite this value with the
# full access path.
# If ![setSyncMode], Safe Base code will not change this value.
set tokens_auto_path {}
foreach dir $raw_auto_path {
if {[dict exists $remap_access_path $dir]} {
lappend tokens_auto_path [dict get $remap_access_path $dir]
}
}
::interp eval $child [list set auto_path $tokens_auto_path]
# Add the tcl::tm directories to the access path.
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
if {!$AutoPathSync} {
set state(auto_path) $raw_auto_path
}
SyncAccessPath $child
return
}
#
# DetokPath:
# Convert tokens to directories where possible.
# Leave undefined tokens unconverted. They are
# nonsense in both the child and the parent.
#
proc ::safe::DetokPath {child tokenPath} {
namespace upvar ::safe [VarName $child] state
set childPath {}
foreach token $tokenPath {
if {[dict exists $state(access_path,map) $token]} {
lappend childPath [dict get $state(access_path,map) $token]
} else {
lappend childPath $token
}
}
return $childPath
}
#
#
# interpFindInAccessPath:
# Search for a real directory and returns its virtual Id (including the
# "$")
#
# When debugging, use TranslatePath for the inverse operation.
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
autoPath
withAutoPath
} {
# Configure will generate an access_path when access_path is empty.
InterpSetConfig $child $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath
# 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 {}
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
}
}
}
}
return $res
}
| | | | | | | | | | | | | | | | | 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 |
}
}
}
}
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
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
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.
| | | | | | | | | | | | | | | | | | | 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 |
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 its recorded access path. Also sets
# tcl_library to the first token of the access path.
#
proc ::safe::SyncAccessPath {child} {
variable AutoPathSync
namespace upvar ::safe [VarName $child] state
set child_access_path $state(access_path,child)
if {$AutoPathSync} {
::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 access path's. See -> InterpSetConfig for the code which
# ensures this condition.
::interp eval $child [list \
set tcl_library [lindex $child_access_path 0]]
return
}
# 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} {
variable AutoPathSync
Log $child "GLOB ! $args" NOTICE
set cmd {}
set at 0
array set got {
-directory 0
-nocomplain 0
-join 0
-tails 0
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
{"-directory" cannot be used with "-path"}
}
set got($opt) 1
set virtualdir [lindex $args [incr at]]
incr at
}
-* {
| | | | | | | | 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 |
{"-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'"
# unsafe/unnecessary options rejected: -path
}
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 (hence -join not copied to $cmd)
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
# "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
| | | | | 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
# "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
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 |
# - [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 {
| | | | | | | | | | | | | | | | | | | | | | < < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# - [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
|
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | # 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 | | | | | | | | | | | | | | | | 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 |
# 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
#
####
variable AutoPathSync
# Share the descriptions
set OptList {
{-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"}
}
if {!$AutoPathSync} {
lappend OptList {-autoPath -list {} "::auto_path for the child"}
}
set temp [::tcl::OptKeyRegister $OptList]
# create case (child is optional)
::tcl::OptKeyRegister {
{?child? -name {} "name of the child (optional)"}
} ::safe::interpCreate
# 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
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 |
set newValue [lindex $args 0]
if {![string is boolean -strict $newValue]} {
return -code error "new value must be a valid boolean"
}
set args [expr {$newValue && $newValue}]
if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
return -code error \
| | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
set newValue [lindex $args 0]
if {![string is boolean -strict $newValue]} {
return -code error "new value must be a valid boolean"
}
set args [expr {$newValue && $newValue}]
if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
return -code error \
"cannot set new value while Safe Base child interpreters exist"
}
if {($args != $AutoPathSync)} {
set AutoPathSync {*}$args
::tcl::OptKeyDelete ::safe::interpCreate
::tcl::OptKeyDelete ::safe::interpIC
set TmpLog [setLogCmd]
Setup
|
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 |
}
namespace eval ::safe {
# internal variables (must not begin with "S")
# AutoPathSync
#
| | | | | | | | | | | | | | | | 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 |
}
namespace eval ::safe {
# internal variables (must not begin with "S")
# AutoPathSync
#
# Set AutoPathSync to 0 to give a child's ::auto_path the same meaning as
# for an unsafe interpreter: the package command will search its directories
# and first-level subdirectories for pkgIndex.tcl files; the auto-loader
# will search its directories for tclIndex files. The access path and
# module path will be maintained as separate values, and ::auto_path will
# not be updated when the user calls ::safe::interpAddToAccessPath to add to
# the access path. If the user specifies an access path when calling
# interpCreate, interpInit or interpConfigure, it is the user's
# responsibility to define the child's auto_path. If these commands are
# called with no (or empty) access path, the child's auto_path will be set
# to a tokenized form of the parent's auto_path, and these directories and
# their first-level subdirectories will be added to the access path.
#
# Set to 1 for "traditional" behavior: a child's entire access path and
# module path are copied to its ::auto_path, which is updated whenever
# the user calls ::safe::interpAddToAccessPath to add to the access path.
variable AutoPathSync 1
# 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 )
# auto_path : List of paths requested by the caller as child's ::auto_path.
# 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
#
# In principle, the child can change its value of ::auto_path -
# - a package might add a path (that is already in the access path) for
# access to tclIndex files;
# - the script might remove some elements of the auto_path.
# However, this is really the business of the parent, and the auto_path will
# be reset whenever the token mapping changes (i.e. when option -accessPath is
# used to change the access path).
# -autoPath is now stored in the array and is no longer obtained from
# the child.
}
::safe::Setup
|
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 |
# 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,
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
| | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
}
}
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
|
| ︙ | ︙ | |||
2794 2795 2796 2797 2798 2799 2800 |
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
variable DefaultValue
| < | 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 |
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]} {
| > | | > > > > > > > > > | 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 |
# 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}
|
| ︙ | ︙ | |||
2884 2885 2886 2887 2888 2889 2890 |
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
| | | 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 |
} ""] $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]
}
| | | 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 |
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.
|
| ︙ | ︙ | |||
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]
| | | 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 |
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]} {
|
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 |
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]
| | | 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 |
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 {
|
| ︙ | ︙ | |||
3229 3230 3231 3232 3233 3234 3235 | # 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 | | | | 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 | # 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. # # Arguments: # string being converted |
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | # 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 \ | | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
# 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/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.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
{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}
| | | | | | | | | | | | 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 |
{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.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
{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}
| | | | | | | | | | | | 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 |
{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/America/Dawson.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
| | > | 89 90 91 92 93 94 95 96 97 98 |
{1478422800 -28800 0 PST}
{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/Whitehorse.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1478422800 -28800 0 PST}
{1489312800 -25200 1 PDT}
{1509872400 -28800 0 PST}
{1520762400 -25200 1 PDT}
{1541322000 -28800 0 PST}
{1552212000 -25200 1 PDT}
{1572771600 -28800 0 PST}
| | > | 89 90 91 92 93 94 95 96 97 98 |
{1478422800 -28800 0 PST}
{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.
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
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}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{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.
| ︙ | ︙ | |||
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}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{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/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/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. |
| ︙ | ︙ |
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.
| ︙ | ︙ | |||
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>"; };
|
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
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>"; };
|
| ︙ | ︙ | |||
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/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
OSSwapBigToHostInt32(finder->creator));
break;
case MACOSX_TYPE_ATTRIBUTE:
*attributePtrPtr = NewOSTypeObj(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
| | | | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
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);
|
| ︙ | ︙ |
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:
|
| ︙ | ︙ |
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 | # 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 Tcl 8.5- package require tcltest 2.5 |
| ︙ | ︙ |
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 |
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]
|
| ︙ | ︙ |
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 Tcltest [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"
}
|
| ︙ | ︙ |
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 |
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
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
|
| ︙ | ︙ | |||
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 |
# 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]
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
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}
|
| ︙ | ︙ |
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 |
# -*- 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
|
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
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]]
| > | > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
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.
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
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
|
| ︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 |
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} {
|
| ︙ | ︙ | |||
3040 3041 3042 3043 3044 3045 3046 |
}
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
|
| ︙ | ︙ | |||
3899 3900 3901 3902 3903 3904 3905 |
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} {
|
| ︙ | ︙ | |||
5330 5331 5332 5333 5334 5335 5336 |
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} 0600]
file stat $path(test3) stats
| | | | 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 |
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} 0600]
file stat $path(test3) stats
set x [format "%#o" [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 "%#o" [expr {$stats(mode) & 0o777}]
} -result [format %#5o [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
|
| ︙ | ︙ | |||
5716 5717 5718 5719 5720 5721 5722 |
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 |
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 {}
|
| ︙ | ︙ | |||
6474 6475 6476 6477 6478 6479 6480 |
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
| | | 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 |
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
|
| ︙ | ︙ | |||
6711 6712 6713 6714 6715 6716 6717 |
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
|
| ︙ | ︙ | |||
6953 6954 6955 6956 6957 6958 6959 |
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
|
| ︙ | ︙ | |||
7026 7027 7028 7029 7030 7031 7032 |
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 {
|
| ︙ | ︙ |
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
|
| ︙ | ︙ | |||
35432 35433 35434 35435 35436 35437 35438 |
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} {
|
| ︙ | ︙ | |||
35901 35902 35903 35904 35905 35906 35907 |
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} {
| | | 35901 35902 35903 35904 35905 35906 35907 35908 35909 35910 35911 35912 35913 35914 35915 |
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]
|
| ︙ | ︙ |
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 Tcltest [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 {
|
| ︙ | ︙ | |||
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 {
|
| ︙ | ︙ | |||
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]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
|
| ︙ | ︙ |
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
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
# Constrain memory leak tests
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
testConstraint testevalex [llength [info commands testevalex]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testdcall [llength [info commands testdcall]]
test dcall-1.1 {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 |
# 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::*
}
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]
}
proc toutf {args} {
variable x
|
| ︙ | ︙ | |||
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} {
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
} {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} {
| | | | | 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 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]]
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
}
} {}
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 |
}
} {}
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乎\u68d9g
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 "乎\u4e5e\u4e5f"; # 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 "乎\u4e5e\u4e5f (\\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
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
package require tcltests
|
| ︙ | ︙ | |||
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]
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
}
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 |
# 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 Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
|
| ︙ | ︙ |
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 |
# 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 Tcltest [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] {
|
| ︙ | ︙ | |||
667 668 669 670 671 672 673 |
} -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 |
# 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 Tcltest [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
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 Tcltest [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 Tcltest [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 |
# 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 Tcltest [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
# Determine if "long int" type is a 32 bit number and if the wide
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
cd [temporaryDirectory]
|
| ︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
# try the location given to use on the commandline to tcltest
::tcltest::loadTestedCommands
load $::reglib Registry
}
testConstraint reg 1
}
}
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 {
| > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
# 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 {
|
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
testConstraint darwin9 [expr {
[testConstraint unix]
&& $tcl_platform(os) eq "Darwin"
&& [package vsatisfies 1.$::tcl_platform(osVersion) 1.9]
}]
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
testConstraint fileSharing 0
testConstraint notFileSharing 1
testConstraint linkFile 1
testConstraint linkDirectory 1
# Several tests require need to match results against the unix username
| > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
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
| | | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
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
| | | | | 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 |
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 {
|
| ︙ | ︙ | |||
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
| | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
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
| | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
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
| | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
}
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
| | | | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
[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
| | | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 |
[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
|
| ︙ | ︙ | |||
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
| | | | 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 |
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
| | | 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 |
} 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
| | | | | | | 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 |
} -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
| | > > | | 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 |
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 Tcltest [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]]]
|
| ︙ | ︙ |
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 |
# 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]
}
|
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
testConstraint loaddll 1
}
# Test for commands defined in Tcltest executable
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
| > > | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
testConstraint loaddll 1
}
# Test for commands defined in Tcltest executable
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 {
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
|
| ︙ | ︙ |
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 |
# 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
}
|
| ︙ | ︙ | |||
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
| | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
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 {
| > > > | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
# 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
|
| ︙ | ︙ |
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 |
# 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]
|
| ︙ | ︙ |
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 |
# -*- 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
if {$::tcl_platform(os) eq "Darwin"} {
|
| ︙ | ︙ |
Changes to tests/httpd11.tcl.
| ︙ | ︙ | |||
233 234 235 236 237 238 239 |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
|
| ︙ | ︙ |
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 |
# -*- 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 Tcltest [info patchlevel]]
testConstraint zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
|
| ︙ | ︙ | |||
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}}}}}}
|
| ︙ | ︙ |
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 |
# 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 {
|
| ︙ | ︙ |
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 Tcltest [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 |
# -*- 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
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | 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]] | > > > | > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
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.
|
| ︙ | ︙ | |||
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 {
|
| ︙ | ︙ | |||
2829 2830 2831 2832 2833 2834 2835 |
# 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} \
| | | 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 |
# 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}
|
| ︙ | ︙ | |||
6083 6084 6085 6086 6087 6088 6089 |
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 |
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 {}
|
| ︙ | ︙ | |||
6891 6892 6893 6894 6895 6896 6897 |
set timer [after 50 lappend z timeout]
vwait z
after cancel $timer
set z
} -cleanup {
close $f
} -result {{delrecursive calling recursive} {delrecursive deleting recursive}}
| | | 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 |
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"
|
| ︙ | ︙ | |||
7573 7574 7575 7576 7577 7578 7579 |
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 |
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 {}}} {
|
| ︙ | ︙ | |||
7639 7640 7641 7642 7643 7644 7645 |
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}
|
| ︙ | ︙ | |||
8127 8128 8129 8130 8131 8132 8133 |
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"
|
| ︙ | ︙ | |||
8754 8755 8756 8757 8758 8759 8760 |
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 |
# -*- 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::*
|
| ︙ | ︙ | |||
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 |
# -*- 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 Tcltest [info patchlevel]]
# Custom constraints used in this file
|
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
# 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]} {
| | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
# 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 |
# -*- 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 Tcltest [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
set minus -
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 |
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
catch { unset minus }
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 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-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 |
# 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 Tcltest [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
|
| ︙ | ︙ | |||
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 |
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
|
| ︙ | ︙ | |||
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]
|
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
} {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\""
| | < > | > < | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
} {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] {
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
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]
| | | > | < < < > > | < < | | | | < | | | < | | | > > | < | > > > | < | | | > > > | 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 |
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 |
# 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}
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
|
| ︙ | ︙ |
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} {
|
| ︙ | ︙ |
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
|
| ︙ | ︙ | |||
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
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
proc failTrace {name1 name2 op} {
|
| ︙ | ︙ |
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 } {
|
| ︙ | ︙ |
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 |
# 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]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
|
| ︙ | ︙ | |||
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 {
|
| ︙ | ︙ | |||
3369 3370 3371 3372 3373 3374 3375 |
} [namespace current]]]
trace add command ::ns2::p2 delete $ondelete
rename ns2::p2 {}
return $res
} -cleanup {
| | | 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 |
} [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
|
| ︙ | ︙ |
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 |
# -*- 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 Tcltest [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands 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 |
# 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 Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
|
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
bytecode
cmdName
dict
regexp
string
} {
set first [string first $t [testobj types]]
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
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 TclOO 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.
|
| ︙ | ︙ | |||
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"}
|
| ︙ | ︙ | |||
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 {}
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 |
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 {
| | | | 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 |
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
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
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 {
| | | | 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 |
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]
|
| ︙ | ︙ | |||
2131 2132 2133 2134 2135 2136 2137 |
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 {
| | | | | | | | | | | | | | | | 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 |
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-15.1 {OO: object cloning} {
|
| ︙ | ︙ | |||
2911 2912 2913 2914 2915 2916 2917 |
} -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 {
| | | | | | | | | | | | | | 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 |
} -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}}"}
|
| ︙ | ︙ | |||
3590 3591 3592 3593 3594 3595 3596 |
} -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 {
| | | | | | | | 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 |
} -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
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 |
variable x!
method y {} {incr x!}
}
foo y
foo y
} -result 2
test oo-27.6 {variables declaration - non-interference of levels} -setup {
| | | | | | | | 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 |
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!
|
| ︙ | ︙ | |||
3688 3689 3690 3691 3692 3693 3694 |
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 {
| | | | | 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 |
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
|
| ︙ | ︙ | |||
3716 3717 3718 3719 3720 3721 3722 |
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 {
| | | | | 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 |
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
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 |
}
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 {
| | | | | | | | | | | | | | | | | 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 |
}
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
|
| ︙ | ︙ | |||
3957 3958 3959 3960 3961 3962 3963 |
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
| | | | | | | 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 |
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 {
|
| ︙ | ︙ |
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 TclOO 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 TclOO 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 |
# 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 Tcltest [info patchlevel]]
# Do all this in a child interp to avoid garbaging the package list
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [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
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testwordend [llength [info commands testwordend]]
testConstraint testbytestring [llength [info commands testbytestring]]
|
| ︙ | ︙ | |||
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
|
| ︙ | ︙ |
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
|
| ︙ | ︙ |
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 |
# 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.
|
| ︙ | ︙ |
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 |
# 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 procbodytest [expr {![catch {package require procbodytest}]}]
testConstraint memory [llength [info commands memory]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
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} {
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
|
| ︙ | ︙ | |||
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]
|
| ︙ | ︙ |
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]]
|
| ︙ | ︙ |
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 } {
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
# Some tests require the testsaveresult command
testConstraint testsaveresult [llength [info commands testsaveresult]]
|
| ︙ | ︙ |
Name change from tests/safe-stock87.test to 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 |
# 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.
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
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}
| < < < < | | | | | | | | | 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 |
lsort $listOut
}
# Force actual loading of the safe package because we use un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
testConstraint AutoSyncDefined 1
# high level general test
test safe-stock-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require opt}]
# no error shall occur:
interp eval $i {::tcl::Lempty {a list}}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 0.4.*
test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# an error shall occur (opt is not anymore in the secure 0-level
# provided deep path)
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
list $token1 $token2 -- \
[catch {interp eval $i {package require opt}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\
{TCLLIB */dummy/unixlike/test/path} -- {}"
test safe-stock-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-stock-7.2, opt should be found
list $token1 $token2 -- \
[catch {interp eval $i {package require opt}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
# Note that the glob match elides directories (those from the module path)
# other than the first and last in the access path.
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\
{TCLLIB * TCLLIB/OPTDIR} -- {}}
test safe-stock-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set i [safe::interpCreate]
interp eval $i {
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package shell} 0}
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading. It was previously test "safe-5.1".
| | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package shell} 0}
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading. It was previously test "safe-5.1".
test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup {
catch {safe::interpDelete a}
safe::interpCreate a
} -body {
interp eval a {tcl_endOfWord "" 0}
} -cleanup {
safe::interpDelete a
} -result -1
test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\
{TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\
0 0 0 example.com}
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\
{TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\
0 0 0 example.com}
test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}}
| | | | | | | | | | | 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 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}}
test safe-stock-18.1 {cf. safe-stock-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
set ::auto_path $::auto_TMP
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require opt}]
# no error shall occur:
interp eval $i {::tcl::Lempty {a list}}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result 0.4.*
test safe-stock-18.2 {cf. safe-stock-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
set auto1 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# an error shall occur (opt is not anymore in the secure 0-level
# provided deep path)
list $auto1 $token1 $token2 \
[catch {interp eval $i {package require opt}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\
{-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
test safe-stock-18.4 {cf. safe-stock-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]]
# should not have been changed by Safe Base:
set auto2 [interp eval $i {set ::auto_path}]
# This time, unlike test safe-stock-18.2opt and the try above, opt should be found:
list $auto1 $auto2 $token1 $token2 \
[catch {interp eval $i {package require opt}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\
{-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
test safe-stock-18.5 {cf. safe-stock-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
|
| ︙ | ︙ |
Changes to tests/safe-zipfs.test.
1 2 3 4 5 6 7 8 9 | # 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. # | | | | | | 1 2 3 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-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.
package require Tcl 8.5-
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]]]
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
testConstraint AutoSyncDefined 1
# Tests 5.* test the example files before using them to test safe interpreters.
| | | | | | | 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 |
testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
testConstraint AutoSyncDefined 1
# Tests 5.* test the example files before using them to test safe interpreters.
test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]
} -body {
# Try to load the commands.
set code3 [catch report1 msg3]
set code4 [catch report2 msg4]
list $code3 $msg3 $code4 $msg4
} -cleanup {
catch {rename report1 {}}
catch {rename report2 {}}
set ::auto_path $tmpAutoPath
auto_reset
} -match glob -result {0 ok1 0 ok2}
test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
} -body {
# Try to load the commands.
set code3 [catch report1 msg3]
set code4 [catch report2 msg4]
list $code3 $msg3 $code4 $msg4
} -cleanup {
catch {rename report1 {}}
catch {rename report2 {}}
set ::auto_path $tmpAutoPath
auto_reset
} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}}
test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
} -body {
# Try to load the packages and run a command from each one.
set code3 [catch {package require SafeTestPackage1} msg3]
set code4 [catch {package require SafeTestPackage2} msg4]
set code5 [catch HeresPackage1 msg5]
set code6 [catch HeresPackage2 msg6]
list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
} -cleanup {
set ::auto_path $tmpAutoPath
catch {package forget SafeTestPackage1}
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup {
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \
[file join $ZipMountPoint auto0 auto2]
} -body {
# Try to load the packages and run a command from each one.
set code3 [catch {package require SafeTestPackage1} msg3]
set code4 [catch {package require SafeTestPackage2} msg4]
set code5 [catch HeresPackage1 msg5]
set code6 [catch HeresPackage2 msg6]
list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
} -cleanup {
set ::auto_path $tmpAutoPath
catch {package forget SafeTestPackage1}
catch {package forget SafeTestPackage2}
catch {rename HeresPackage1 {}}
catch {rename HeresPackage2 {}}
} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup {
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
}
tcl::tm::path add [file join $ZipMountPoint auto0 modules]
} -body {
# Try to load the modules and run a command from each one.
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
}
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}
| | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
}
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]
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
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
| | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $ZipMountPoint auto0]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i {HeresPackage1}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
# provided deep path)
list $token1 $token2 $token3 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found
list $token1 $token2 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync; zipfs} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
} -body {
# For complete correspondence to safe-stock-9.11, include auto0 in access path.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $ZipMountPoint auto0] \
[file join $ZipMountPoint auto0 auto1] \
[file join $ZipMountPoint auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\
ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
| | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\
ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in
# tokenized form to the child's access path, and then adds all the
# descendants, discovered recursively by using glob.
# - The order of the directories in the list returned by glob is system-dependent,
# and therefore this is true also for (a) the order of token assignment to
# descendants of the [tcl::tm::list] roots; and (b) the order of those same
# directories in the access path. Both those things must be sorted before
# comparing with expected results. The test is therefore not totally strict,
# but will notice missing or surplus directories.
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
| | | | 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 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file join $ZipMountPoint auto0]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
set ::auto_path $::auto_TMP
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i HeresPackage1
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
set auto1 [interp eval $i {set ::auto_path}]
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
set auto1 [interp eval $i {set ::auto_path}]
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
# an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
# provided deep path)
list $auto1 $token1 $token2 $token3 \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 |
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
# This will differ from the value -autoPath {}
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
# should not have been changed by Safe Base:
set auto2 [interp eval $i {set ::auto_path}]
# This will differ from the value -autoPath {}
set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]]
|
| ︙ | ︙ |
Changes to tests/safe.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # - 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 17.1 17.2 17.4 # - 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 | | | | < < | | | | | | 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 |
# - 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 17.1 17.2 17.4
# - 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 getAutoPath {child} {
set ap1 [lrange [lindex [safe::interpConfigure $child -autoPath] 1] 0 end]
set ap2 [::safe::DetokPath $child [interp eval $child set ::auto_path]]
list $ap1 -- $ap2
}
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
lappend listOut [string map $map $element]
}
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
testConstraint AutoSyncDefined 1
### 1. Basic help/error messages.
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
| | | | | | 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 |
testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
testConstraint AutoSyncDefined 1
### 1. Basic help/error messages.
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
} -result {no value given for parameter "child" (use -help for full usage) :
child name () name of the child}
test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
} else {
set SyncVal_TMP 1
}
} -body {
safe::interpCreate -help
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
?child? name () name of the child (optional)
-accessPath list () access path for the child
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook}
test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
| | | | | | 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 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
?child? name () name of the child (optional)
-accessPath list () access path for the child
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook
-autoPath list () ::auto_path for the child}
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}
### 2. Aliases in a new "interp create" interpreter.
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
# Disabled this test. It tests nothing sensible. [Bug 999612]
# interp aliases
} ""
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
### 5. Test the example files before using them to test safe interpreters.
| | | | | | | | 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 |
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
### 5. Test the example files before using them to test safe interpreters.
### The old test "safe-5.1" has been moved to "safe-stock-9.8".
### A replacement test using example files is "safe-9.8".
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.
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
}
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}
| | | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
}
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]
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
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
| | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i {HeresPackage1}
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | | | 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 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
list $token1 $token2 $token3 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\
1 {can't find package SafeTestPackage1} --\
{TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}}
test safe-7.3 {check that safe subinterpreters work} {
set g [interp children]
if {$g ne {}} {
append g { -- residue of an earlier test}
}
set h [info vars ::safe::S*]
if {$h ne {}} {
append h { -- residue of an earlier test}
}
set i [safe::interpCreate]
set j [safe::interpCreate [list $i x]]
list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \
[interp exists $j] [info vars ::safe::S*]
} {{} {} ok {} 0 {}}
test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup {
} -body {
set g [interp children]
if {$g ne {}} {
append g { -- residue of an earlier test}
}
set h [info vars ::safe::S*]
if {$h ne {}} {
append h { -- residue of an earlier test}
}
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
} else {
set SyncVal_TMP 1
}
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
# this time, unlike test safe-7.2, SafeTestPackage1 should be found
list $token1 $token2 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
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
| | | | | | | 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 |
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]
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
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
| | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
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]
} {}
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
| | | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in
# tokenized form to the child's access path, and then adds all the
# descendants, discovered recursively by using glob.
# - The order of the directories in the list returned by glob is system-dependent,
# and therefore this is true also for (a) the order of token assignment to
# descendants of the [tcl::tm::list] roots; and (b) the order of those same
# directories in the access path. Both those things must be sorted before
# comparing with expected results. The test is therefore not totally strict,
# but will notice missing or surplus directories.
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
rename buildEnvironment2 {}
### 14. Sanity checks on paths - module path, access path, auto_path.
| | | | 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 |
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
rename buildEnvironment2 {}
### 14. Sanity checks on paths - module path, access path, auto_path.
test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
set tm {}
foreach token [$i eval ::tcl::tm::path list] {
lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
}
return $tm
} -cleanup {
safe::interpDelete $i
} -result [::tcl::tm::path list]
test safe-14.2 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set lib1 [info library]
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library]]
| | | 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 |
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library]]
test safe-14.2.1 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 |
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library] [info library]]
| | | | | | 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 |
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library] [info library]]
test safe-14.3 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib2 $lib1]
# Unexpected order, should be reversed in the child
set i [safe::interpCreate]
} -body {
set autoList {}
set token [lindex [$i eval set ::auto_path] 0]
set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
return [list [lindex $accessList 0] $auto0]
} -cleanup {
set ::auto_path $::auto_TMP
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [info library] [info library]]
test safe-14.3.1 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set lib1 [info library]
set lib2 [file dirname $lib1]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib2 $lib1]
# Unexpected order, should be reversed in the child
set i [safe::interpCreate]
} -body {
set autoList {}
set token [lindex [$i eval set ::auto_path] 0]
set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
|
| ︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
| | | | 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 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
# Without AutoPathSync, we need a more complete auto_path,
# because the child will use the same value.
set lib1 [info library]
set lib2 [file join $TestsDir auto0]
set ::auto_TMP $::auto_path
set ::auto_path [list $lib1 $lib2]
set i [safe::interpCreate]
set ::auto_path $::auto_TMP
} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
interp eval $i HeresPackage1
set v
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 |
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
# This does not change the value of option -autoPath:
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | | 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 |
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not have been set by Safe Base:
set auto1 [interp eval $i {set ::auto_path}]
# This does not change the value of option -autoPath:
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
# an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
list $auto1 $token1 $token2 $token3 \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -cleanup {
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\
1 {can't find package SafeTestPackage1}\
{-accessPath {[list $tcl_library \
*/dummy/unixlike/test/path \
$TestsDir/auto0]}\
-statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
# (not a counterpart of safe-7.3)
test safe-17.3 {Check that default auto_path is the same as in the parent interpreter, Sync Mode off} -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
|
| ︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 |
# This does not change the value of option -autoPath.
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
| | | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 |
# This does not change the value of option -autoPath.
interp eval $i {set ::auto_path [list {$p(:0:)}]}
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
# should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
# should add as p* (not p2 if parent has a module path)
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]]
# should not have been changed by Safe Base:
set auto2 [interp eval $i {set ::auto_path}]
set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]]
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package test1} 0}
| | | 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result {1 {can't find package test1} 0}
### 18. Test tokenization of directories available to a child.
test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 1
}
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
| | | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# Test that although -autoPath is unchanged, the child's ::auto_path changes to
# reflect the changes in token mappings.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0] \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0]]]
|
| ︙ | ︙ | |||
2671 2672 2673 2674 2675 2676 2677 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
| | | | 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 |
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
# Test that although -autoPath is unchanged, the child's ::auto_path changes to
# reflect the changes in token mappings; and that it is based on the -autoPath
# value, not the previously restricted child ::auto_path.
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0]] \
-autoPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
[file join $TestsDir auto0 auto2]]]
# Inspect.
set confA [safe::interpConfigure $i]
|
| ︙ | ︙ | |||
2737 2738 2739 2740 2741 2742 2743 |
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set tmpAutoPath $::auto_path
set ::auto_path [list $tcl_library [file join $TestsDir auto0]]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
| | | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 |
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
set tmpAutoPath $::auto_path
set ::auto_path [list $tcl_library [file join $TestsDir auto0]]
set i [safe::interpCreate]
set ::auto_path $tmpAutoPath
} -body {
# Test that the -autoPath acquires and keeps the parent's value unless otherwise specified.
# Inspect.
set confA [safe::interpConfigure $i]
set mappC [mapList $PathMapp [dict get $confA -autoPath]]
set toksC [interp eval $i set ::auto_path]
# Load pkgIndex.tcl data.
|
| ︙ | ︙ | |||
3120 3121 3122 3123 3124 3125 3126 | # See comments on lsort after test safe-9.20. ### 20. safe::interpCreate with different cases of -accessPath, -autoPath. set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]] | | | | 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 |
# See comments on lsort after test safe-9.20.
### 20. safe::interpCreate with different cases of -accessPath, -autoPath.
set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]]
test safe-20.1 "create -accessPath NULL -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
} -body {
set i [safe::interpCreate]
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list $::auto_path -- $::auto_path]
test safe-20.2 "create -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
|
| ︙ | ︙ | |||
3345 3346 3347 3348 3349 3350 3351 |
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
| | | 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 |
getAutoPath $i
} -cleanup {
safe::interpDelete $i
if {$SyncExists} {
safe::setSyncMode $SyncVal_TMP
}
} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
if {$SyncExists} {
set SyncVal_TMP [safe::setSyncMode]
safe::setSyncMode 0
} else {
error {This test is meaningful only if the command ::safe::setSyncMode is defined}
}
|
| ︙ | ︙ |
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}]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
|
| ︙ | ︙ |
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: # ------------------------------------------ # |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
# 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]} {
| | > > | > | > > | 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 |
# 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 Tcltest [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 {
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
}
}
}
# 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"
}
}
#
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
proc readpipe {pipe} {
while {![string is integer [set ::done [gets $pipe]]]} {}
}
vwait ::done
close $f
set ::done
} 0
| | | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
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
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
puts $f [list set localhost $localhost]
puts $f {
gets stdin port
socket $localhost $port
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
| | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
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
|
| ︙ | ︙ | |||
1539 1540 1541 1542 1543 1544 1545 |
fileevent $c readable "readlittle $c"
vwait done
list $spurious $len $done
} -cleanup {
after cancel $timer
sendCommand {close $server}
} -result {0 2690 1}
| | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
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
}
|
| ︙ | ︙ | |||
1863 1864 1865 1866 1867 1868 1869 |
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 1 "== test \[$::localhost\]:$port $testmode =="
| | | | | | | | | | | | | 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 |
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 1 "== 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 1 "** 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]
}
|
| ︙ | ︙ | |||
1927 1928 1929 1930 1931 1932 1933 |
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== stop / $::count =="
| | | | | | 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 |
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== 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
|
| ︙ | ︙ | |||
2097 2098 2099 2100 2101 2102 2103 |
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} \
| | | 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 |
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} \
|
| ︙ | ︙ | |||
2385 2386 2387 2388 2389 2390 2391 |
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} \
| | | 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
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
|
| ︙ | ︙ | |||
2432 2433 2434 2435 2436 2437 2438 |
set x
} -cleanup {
close $s
unset x s
} -result {connection refused}
test socket-14.13 {testing writable event when quick failure} \
| | | 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 |
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
|
| ︙ | ︙ | |||
2516 2517 2518 2519 2520 2521 2522 |
} -cleanup {
catch {close $ssock}
catch {close $csock1}
catch {close $csock2}
} -result {}
test socket-14.19 {tip 456 -- introduce the -reuseport option} \
| | | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 |
} -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} {
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
# Helper commands to test various optimizations, code paths, and special cases.
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
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
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
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} {
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
} 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
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
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
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
# 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}]
}
| | | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
# 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
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 |
} {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
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
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
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
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}
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
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-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"}}
| > > > > > > > > > > > > > > | 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 |
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"}}
|
| ︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 1654 |
}
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
|
| ︙ | ︙ | |||
2099 2100 2101 2102 2103 2104 2105 |
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
|
| ︙ | ︙ | |||
2226 2227 2228 2229 2230 2231 2232 |
# 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
|
| ︙ | ︙ | |||
2257 2258 2259 2260 2261 2262 2263 |
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
|
| ︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 |
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} {
|
| ︙ | ︙ | |||
2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
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 Tcltest [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 |
# 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 Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testnrelevels [llength [info commands 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 |
}
}
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]
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
-constraints {unix notRoot}
-body {
| | | | | 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 |
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 |
# 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
|
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
rename update ""
thread::release
}
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
| | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
|
| ︙ | ︙ | |||
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
# Figure out what extension is used for shared libraries on this
|
| ︙ | ︙ | |||
34 35 36 37 38 39 40 |
# 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]
| < < < | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
# 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}]
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
} {{{} {} {}} {} 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 package name} -setup {
| | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
} {{{} {} {}} {} 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 package name} -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 package name} -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}]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
|
| ︙ | ︙ | |||
249 250 251 252 253 254 255 |
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} {
| | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
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} {
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
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} {
| | | | | | 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 |
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} {
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint controversialNaN 1
|
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
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 |
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]
|
| ︙ | ︙ | |||
814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
} -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-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
| > > > | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
} -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
} {-0.0}
|
| ︙ | ︙ |
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 |
# 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 Tcltest [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
|
| ︙ | ︙ | |||
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 Tcltest [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 Tcltest [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 |
# 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 Tcltest [info patchlevel]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
|
| ︙ | ︙ |
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 Tcltest [info patchlevel]
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
}
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 Tcltest [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 |
# 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
|
| ︙ | ︙ |
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
|
| ︙ | ︙ | |||
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
|
| ︙ | ︙ |
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/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. # |
| ︙ | ︙ |
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. # |
| ︙ | ︙ |
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 --
|
| ︙ | ︙ |
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 |
#
# 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]}] {} \
|
| ︙ | ︙ |
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.
| ︙ | ︙ | |||
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]]
}
####################################################################
|
| ︙ | ︙ |
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/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 |
# 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 {
|
| ︙ | ︙ |
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]
|
| ︙ | ︙ |
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.
|
| ︙ | ︙ |
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
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
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]} {
| | | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
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/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
}
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
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.
*
| | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
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.
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
957 958 959 960 961 962 963 | 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"; \
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | @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 | | | | 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 | @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" |
| ︙ | ︙ | |||
2204 2205 2206 2207 2208 2209 2210 | 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 |
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
|
| ︙ | ︙ | |||
2296 2297 2298 2299 2300 2301 2302 | $(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 | < | 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 | $(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 \ |
| ︙ | ︙ | |||
2318 2319 2320 2321 2322 2323 2324 | 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 | | < | < | | 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 | 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 $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs cp $(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"; \ |
| ︙ | ︙ |
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.
| ︙ | ︙ | |||
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)
| | < | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 |
--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
|
| ︙ | ︙ | |||
3978 3979 3980 3981 3982 3983 3984 |
cat >>confdefs.h <<_ACEOF
#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
_ACEOF
else
| | | 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 |
cat >>confdefs.h <<_ACEOF
#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
_ACEOF
else
$as_echo "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
fi
#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
5032 5033 5034 5035 5036 5037 5038 |
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
| | | 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 |
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"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
|
| ︙ | ︙ | |||
5306 5307 5308 5309 5310 5311 5312 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 |
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"
|
| ︙ | ︙ | |||
6555 6556 6557 6558 6559 6560 6561 |
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
| | | 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 |
# 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*) ;;
|
| ︙ | ︙ | |||
8635 8636 8637 8638 8639 8640 8641 |
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main ()
{
| | | 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 |
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <time.h>
int
main ()
{
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
|
| ︙ | ︙ |
Changes to unix/dltest/pkga.c.
| ︙ | ︙ | |||
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;
}
|
| ︙ | ︙ |
Changes to unix/dltest/pkgb.c.
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/dltest/pkgd.c.
| ︙ | ︙ | |||
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;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/dltest/pkgooa.c.
| ︙ | ︙ | |||
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. */
{
|
| ︙ | ︙ |
Changes to unix/dltest/pkgua.c.
| ︙ | ︙ | |||
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;
}
|
| ︙ | ︙ |
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/tcl.m4.
| ︙ | ︙ | |||
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
| | | 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"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 | SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; | | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 |
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"
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
# 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*) ;;
| | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 |
# 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*) ;;
|
| ︙ | ︙ | |||
2128 2129 2130 2131 2132 2133 2134 |
AC_TRY_COMPILE([#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, [
| | | 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 |
AC_TRY_COMPILE([#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_TRY_COMPILE([#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
|
| ︙ | ︙ | |||
2441 2442 2443 2444 2445 2446 2447 |
# TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding,
AC_HELP_STRING([--with-encoding],
| | | | 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 |
# TCL_CFGVAL_ENCODING
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_CFG_ENCODING], [
AC_ARG_WITH(encoding,
AC_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
#
|
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
* 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 |
* 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.
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
result = TCL_OK;
} else {
| | > | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
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",
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
ckfree(ptr);
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
ckfree(dyldLoadHandle);
ckfree(loadHandle);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
ckfree(ptr);
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
ckfree(dyldLoadHandle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclpLoadMemoryGetBuffer --
*
* Allocate a buffer that can be used with TclpLoadMemory() below.
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
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 |
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.
| ︙ | ︙ | |||
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 |
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.
| ︙ | ︙ | |||
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 |
* 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/tclUnixChan.c.
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
* 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);
| | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
* 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;
}
/*
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
* 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);
| | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
* 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;
}
/*
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
| ︙ | ︙ | |||
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);
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 |
}
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);
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
}
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;
|
| ︙ | ︙ | |||
2407 2408 2409 2410 2411 2412 2413 |
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;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
| | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 |
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
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
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.
*/
|
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
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;
}
|
| ︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 | } /* * Extract the process IDs from the pipe structure. */ pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan); | | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
}
/*
* 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/tclUnixSock.c.
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
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 |
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.
*/
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
# 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 |
# 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);
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 |
int bytesRead;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0);
| | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
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.
*/
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
| | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
*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;
}
/*
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | 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) | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | 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 |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
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 = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(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}] Dde];\
package ifneeded registry 1.3.5 [list load [file normalize ${REG_DLL_FILE}] Registry]
TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}]];\
$(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@
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
$(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;
| | | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 |
$(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";
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 | 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/configure.
| ︙ | ︙ | |||
3745 3746 3747 3748 3749 3750 3751 |
if test x"${with_tcencoding}" != x ; then
cat >>confdefs.h <<_ACEOF
#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
_ACEOF
else
| < | | 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 |
if test x"${with_tcencoding}" != x ; then
cat >>confdefs.h <<_ACEOF
#define TCL_CFGVAL_ENCODING "${with_tcencoding}"
_ACEOF
else
$as_echo "#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.
|
| ︙ | ︙ | |||
4200 4201 4202 4203 4204 4205 4206 |
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} \
| | | | 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 |
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"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
|
| ︙ | ︙ | |||
5292 5293 5294 5295 5296 5297 5298 |
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}\""
| > | > > > | 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 |
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}"
|
| ︙ | ︙ | |||
5438 5439 5440 5441 5442 5443 5444 |
| | | 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 | 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. |
| ︙ | ︙ | |||
6147 6148 6149 6150 6151 6152 6153 |
# 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" ;;
| < | 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 |
# 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
|
| ︙ | ︙ |
Changes to win/configure.ac.
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
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}\""
| > | > > > | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
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}"
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) | | | 505 506 507 508 509 510 511 512 513 514 515 516 | AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) AC_OUTPUT(Makefile tclConfig.sh tclsh.exe.manifest) dnl Local Variables: dnl mode: autoconf; dnl End: |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
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. # | < < < < | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | # 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 # |
| ︙ | ︙ | |||
469 470 471 472 473 474 475 | !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 << | | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 | !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:\=/)" Dde] package ifneeded registry 1.3.5 [list load "$(TCLREGLIB:\=/)" Registry] << runtest: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls |
| ︙ | ︙ |
Changes to win/rules.vc.
| ︙ | ︙ | |||
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. # |
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 | # 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 | | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 | # 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 |
| ︙ | ︙ | |||
1665 1666 1667 1668 1669 1670 1671 |
@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
| | | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 |
@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.
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | !ifndef DISABLE_IMPLICIT_RULES DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and | | | 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
!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::
|
| ︙ | ︙ |
Changes to win/tcl.dsp.
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
657 658 659 660 661 662 663 |
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} \
| | | | 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 |
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"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
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
| < | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
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
|
| ︙ | ︙ |
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) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES 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; |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
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) && defined(TCL_USE_STATIC_PACKAGES) && TCL_USE_STATIC_PACKAGES
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);
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
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 --
|
| ︙ | ︙ | |||
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.
| ︙ | ︙ | |||
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;
| < | 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
* 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) {
|
| ︙ | ︙ | |||
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;
| < | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
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;
|
| ︙ | ︙ | |||
1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
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 {
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
Tcl_WCharToUtfDString(buf, size-1, bufferPtr);
| > | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 |
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);
|
| ︙ | ︙ | |||
2814 2815 2816 2817 2818 2819 2820 |
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
int len;
| < | 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 |
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);
|
| ︙ | ︙ |
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
int length;
| | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
{
#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.
*/
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
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).
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 |
}
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);
}
|
| ︙ | ︙ |
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
293 294 295 296 297 298 299 | #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 | #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) |
| ︙ | ︙ | |||
435 436 437 438 439 440 441 | # 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/tclWinSerial.c.
| ︙ | ︙ | |||
1822 1823 1824 1825 1826 1827 1828 |
}
/*
* 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
*/
|
| ︙ | ︙ |